From 5ff904cd2796bde6db3cd5141264151295b186c9 Mon Sep 17 00:00:00 2001 From: Jeff Law Date: Tue, 12 Aug 1997 01:47:32 -0600 Subject: [PATCH] Initial revision From-SVN: r14772 --- gcc/f/BUGS | 198 + gcc/f/ChangeLog | 3721 ++++ gcc/f/INSTALL | 1517 ++ gcc/f/Make-lang.in | 567 + gcc/f/Makefile.in | 562 + gcc/f/NEWS | 1064 ++ gcc/f/README | 7 + gcc/f/assert.j | 27 + gcc/f/bad.c | 543 + gcc/f/bad.def | 705 + gcc/f/bad.h | 108 + gcc/f/bit.c | 201 + gcc/f/bit.h | 84 + gcc/f/bld-op.def | 69 + gcc/f/bld.c | 5782 ++++++ gcc/f/bld.h | 1009 + gcc/f/bugs.texi | 287 + gcc/f/bugs0.texi | 17 + gcc/f/com-rt.def | 281 + gcc/f/com.c | 16225 ++++++++++++++++ gcc/f/com.h | 419 + gcc/f/config-lang.in | 100 + gcc/f/config.j | 27 + gcc/f/convert.j | 28 + gcc/f/data.c | 1810 ++ gcc/f/data.h | 74 + gcc/f/equiv.c | 1444 ++ gcc/f/equiv.h | 101 + gcc/f/expr.c | 19405 +++++++++++++++++++ gcc/f/expr.h | 194 + gcc/f/fini.c | 774 + gcc/f/flags.j | 27 + gcc/f/g77.1 | 364 + gcc/f/g77.c | 1557 ++ gcc/f/g77.texi | 13831 ++++++++++++++ gcc/f/gbe/2.7.2.2.diff | 11296 +++++++++++ gcc/f/gbe/README | 45 + gcc/f/glimits.j | 28 + gcc/f/global.c | 1490 ++ gcc/f/global.h | 201 + gcc/f/hconfig.j | 27 + gcc/f/implic.c | 383 + gcc/f/implic.h | 74 + gcc/f/info-b.def | 36 + gcc/f/info-k.def | 37 + gcc/f/info-w.def | 41 + gcc/f/info.c | 305 + gcc/f/info.h | 186 + gcc/f/input.j | 27 + gcc/f/install.texi | 2036 ++ gcc/f/install0.texi | 14 + gcc/f/intdoc.c | 1339 ++ gcc/f/intdoc.h | 2370 +++ gcc/f/intdoc.texi | 10570 +++++++++++ gcc/f/intrin.c | 2047 ++ gcc/f/intrin.def | 3350 ++++ gcc/f/intrin.h | 130 + gcc/f/lab.c | 159 + gcc/f/lab.h | 154 + gcc/f/lang-options.h | 152 + gcc/f/lang-specs.h | 96 + gcc/f/lex.c | 4697 +++++ gcc/f/lex.h | 202 + gcc/f/malloc.c | 565 + gcc/f/malloc.h | 183 + gcc/f/name.c | 242 + gcc/f/name.h | 109 + gcc/f/news.texi | 1468 ++ gcc/f/news0.texi | 14 + gcc/f/parse.c | 93 + gcc/f/proj.c | 71 + gcc/f/proj.h | 102 + gcc/f/rtl.j | 28 + gcc/f/runtime/ChangeLog | 698 + gcc/f/runtime/Makefile.in | 251 + gcc/f/runtime/README | 46 + gcc/f/runtime/TODO | 17 + gcc/f/runtime/changes.netlib | 2836 +++ gcc/f/runtime/configure | 2048 ++ gcc/f/runtime/configure.in | 371 + gcc/f/runtime/disclaimer.netlib | 15 + gcc/f/runtime/f2c.h.in | 227 + gcc/f/runtime/f2cext.c | 565 + gcc/f/runtime/libF77/F77_aloc.c | 32 + gcc/f/runtime/libF77/Makefile.in | 95 + gcc/f/runtime/libF77/Notice | 23 + gcc/f/runtime/libF77/README.netlib | 108 + gcc/f/runtime/libF77/Version.c | 65 + gcc/f/runtime/libF77/abort_.c | 18 + gcc/f/runtime/libF77/c_abs.c | 14 + gcc/f/runtime/libF77/c_cos.c | 21 + gcc/f/runtime/libF77/c_div.c | 40 + gcc/f/runtime/libF77/c_exp.c | 23 + gcc/f/runtime/libF77/c_log.c | 21 + gcc/f/runtime/libF77/c_sin.c | 21 + gcc/f/runtime/libF77/c_sqrt.c | 38 + gcc/f/runtime/libF77/cabs.c | 27 + gcc/f/runtime/libF77/d_abs.c | 12 + gcc/f/runtime/libF77/d_acos.c | 13 + gcc/f/runtime/libF77/d_asin.c | 13 + gcc/f/runtime/libF77/d_atan.c | 13 + gcc/f/runtime/libF77/d_atn2.c | 13 + gcc/f/runtime/libF77/d_cnjg.c | 17 + gcc/f/runtime/libF77/d_cos.c | 13 + gcc/f/runtime/libF77/d_cosh.c | 13 + gcc/f/runtime/libF77/d_dim.c | 10 + gcc/f/runtime/libF77/d_exp.c | 13 + gcc/f/runtime/libF77/d_imag.c | 10 + gcc/f/runtime/libF77/d_int.c | 13 + gcc/f/runtime/libF77/d_lg10.c | 15 + gcc/f/runtime/libF77/d_log.c | 13 + gcc/f/runtime/libF77/d_mod.c | 40 + gcc/f/runtime/libF77/d_nint.c | 14 + gcc/f/runtime/libF77/d_prod.c | 10 + gcc/f/runtime/libF77/d_sign.c | 12 + gcc/f/runtime/libF77/d_sin.c | 13 + gcc/f/runtime/libF77/d_sinh.c | 13 + gcc/f/runtime/libF77/d_sqrt.c | 13 + gcc/f/runtime/libF77/d_tan.c | 13 + gcc/f/runtime/libF77/d_tanh.c | 13 + gcc/f/runtime/libF77/derf_.c | 12 + gcc/f/runtime/libF77/derfc_.c | 14 + gcc/f/runtime/libF77/dtime_.c | 45 + gcc/f/runtime/libF77/ef1asc_.c | 21 + gcc/f/runtime/libF77/ef1cmc_.c | 14 + gcc/f/runtime/libF77/erf_.c | 12 + gcc/f/runtime/libF77/erfc_.c | 12 + gcc/f/runtime/libF77/etime_.c | 38 + gcc/f/runtime/libF77/exit_.c | 37 + gcc/f/runtime/libF77/f2ch.add | 162 + gcc/f/runtime/libF77/getarg_.c | 28 + gcc/f/runtime/libF77/getenv_.c | 51 + gcc/f/runtime/libF77/h_abs.c | 12 + gcc/f/runtime/libF77/h_dim.c | 10 + gcc/f/runtime/libF77/h_dnnt.c | 14 + gcc/f/runtime/libF77/h_indx.c | 26 + gcc/f/runtime/libF77/h_len.c | 10 + gcc/f/runtime/libF77/h_mod.c | 10 + gcc/f/runtime/libF77/h_nint.c | 14 + gcc/f/runtime/libF77/h_sign.c | 12 + gcc/f/runtime/libF77/hl_ge.c | 12 + gcc/f/runtime/libF77/hl_gt.c | 12 + gcc/f/runtime/libF77/hl_le.c | 12 + gcc/f/runtime/libF77/hl_lt.c | 12 + gcc/f/runtime/libF77/i_abs.c | 12 + gcc/f/runtime/libF77/i_dim.c | 10 + gcc/f/runtime/libF77/i_dnnt.c | 14 + gcc/f/runtime/libF77/i_indx.c | 26 + gcc/f/runtime/libF77/i_len.c | 10 + gcc/f/runtime/libF77/i_mod.c | 10 + gcc/f/runtime/libF77/i_nint.c | 14 + gcc/f/runtime/libF77/i_sign.c | 12 + gcc/f/runtime/libF77/iargc_.c | 11 + gcc/f/runtime/libF77/l_ge.c | 12 + gcc/f/runtime/libF77/l_gt.c | 12 + gcc/f/runtime/libF77/l_le.c | 12 + gcc/f/runtime/libF77/l_lt.c | 12 + gcc/f/runtime/libF77/lbitbits.c | 62 + gcc/f/runtime/libF77/lbitshft.c | 11 + gcc/f/runtime/libF77/main.c | 135 + gcc/f/runtime/libF77/makefile.netlib | 103 + gcc/f/runtime/libF77/pow_ci.c | 20 + gcc/f/runtime/libF77/pow_dd.c | 13 + gcc/f/runtime/libF77/pow_di.c | 35 + gcc/f/runtime/libF77/pow_hh.c | 33 + gcc/f/runtime/libF77/pow_ii.c | 33 + gcc/f/runtime/libF77/pow_qq.c | 33 + gcc/f/runtime/libF77/pow_ri.c | 35 + gcc/f/runtime/libF77/pow_zi.c | 61 + gcc/f/runtime/libF77/pow_zz.c | 23 + gcc/f/runtime/libF77/qbitbits.c | 66 + gcc/f/runtime/libF77/qbitshft.c | 11 + gcc/f/runtime/libF77/r_abs.c | 12 + gcc/f/runtime/libF77/r_acos.c | 13 + gcc/f/runtime/libF77/r_asin.c | 13 + gcc/f/runtime/libF77/r_atan.c | 13 + gcc/f/runtime/libF77/r_atn2.c | 13 + gcc/f/runtime/libF77/r_cnjg.c | 16 + gcc/f/runtime/libF77/r_cos.c | 13 + gcc/f/runtime/libF77/r_cosh.c | 13 + gcc/f/runtime/libF77/r_dim.c | 10 + gcc/f/runtime/libF77/r_exp.c | 13 + gcc/f/runtime/libF77/r_imag.c | 10 + gcc/f/runtime/libF77/r_int.c | 13 + gcc/f/runtime/libF77/r_lg10.c | 15 + gcc/f/runtime/libF77/r_log.c | 13 + gcc/f/runtime/libF77/r_mod.c | 40 + gcc/f/runtime/libF77/r_nint.c | 14 + gcc/f/runtime/libF77/r_sign.c | 12 + gcc/f/runtime/libF77/r_sin.c | 13 + gcc/f/runtime/libF77/r_sinh.c | 13 + gcc/f/runtime/libF77/r_sqrt.c | 13 + gcc/f/runtime/libF77/r_tan.c | 13 + gcc/f/runtime/libF77/r_tanh.c | 13 + gcc/f/runtime/libF77/s_cat.c | 75 + gcc/f/runtime/libF77/s_cmp.c | 44 + gcc/f/runtime/libF77/s_copy.c | 51 + gcc/f/runtime/libF77/s_paus.c | 88 + gcc/f/runtime/libF77/s_rnge.c | 26 + gcc/f/runtime/libF77/s_stop.c | 37 + gcc/f/runtime/libF77/sig_die.c | 45 + gcc/f/runtime/libF77/signal1.h | 5 + gcc/f/runtime/libF77/signal1.h0 | 25 + gcc/f/runtime/libF77/signal_.c | 14 + gcc/f/runtime/libF77/system_.c | 36 + gcc/f/runtime/libF77/z_abs.c | 12 + gcc/f/runtime/libF77/z_cos.c | 19 + gcc/f/runtime/libF77/z_div.c | 39 + gcc/f/runtime/libF77/z_exp.c | 21 + gcc/f/runtime/libF77/z_log.c | 20 + gcc/f/runtime/libF77/z_sin.c | 19 + gcc/f/runtime/libF77/z_sqrt.c | 33 + gcc/f/runtime/libI77/Makefile.in | 129 + gcc/f/runtime/libI77/Notice | 23 + gcc/f/runtime/libI77/README.netlib | 225 + gcc/f/runtime/libI77/Version.c | 272 + gcc/f/runtime/libI77/backspace.c | 101 + gcc/f/runtime/libI77/close.c | 99 + gcc/f/runtime/libI77/dfe.c | 156 + gcc/f/runtime/libI77/dolio.c | 20 + gcc/f/runtime/libI77/due.c | 73 + gcc/f/runtime/libI77/endfile.c | 195 + gcc/f/runtime/libI77/err.c | 298 + gcc/f/runtime/libI77/f2ch.add | 162 + gcc/f/runtime/libI77/fio.h | 102 + gcc/f/runtime/libI77/fmt.c | 516 + gcc/f/runtime/libI77/fmt.h | 99 + gcc/f/runtime/libI77/fmtlib.c | 45 + gcc/f/runtime/libI77/fp.h | 28 + gcc/f/runtime/libI77/ftell_.c | 46 + gcc/f/runtime/libI77/iio.c | 147 + gcc/f/runtime/libI77/ilnw.c | 82 + gcc/f/runtime/libI77/inquire.c | 108 + gcc/f/runtime/libI77/lio.h | 74 + gcc/f/runtime/libI77/lread.c | 684 + gcc/f/runtime/libI77/lwrite.c | 310 + gcc/f/runtime/libI77/makefile.netlib | 104 + gcc/f/runtime/libI77/open.c | 245 + gcc/f/runtime/libI77/rawio.h | 45 + gcc/f/runtime/libI77/rdfmt.c | 476 + gcc/f/runtime/libI77/rewind.c | 26 + gcc/f/runtime/libI77/rsfe.c | 80 + gcc/f/runtime/libI77/rsli.c | 105 + gcc/f/runtime/libI77/rsne.c | 607 + gcc/f/runtime/libI77/sfe.c | 44 + gcc/f/runtime/libI77/sue.c | 87 + gcc/f/runtime/libI77/typesize.c | 12 + gcc/f/runtime/libI77/uio.c | 69 + gcc/f/runtime/libI77/util.c | 51 + gcc/f/runtime/libI77/wref.c | 276 + gcc/f/runtime/libI77/wrtfmt.c | 385 + gcc/f/runtime/libI77/wsfe.c | 85 + gcc/f/runtime/libI77/wsle.c | 41 + gcc/f/runtime/libI77/wsne.c | 26 + gcc/f/runtime/libI77/xwsne.c | 72 + gcc/f/runtime/libU77/COPYING.LIB | 481 + gcc/f/runtime/libU77/Makefile.in | 155 + gcc/f/runtime/libU77/PROJECTS | 10 + gcc/f/runtime/libU77/README | 40 + gcc/f/runtime/libU77/Version.c | 12 + gcc/f/runtime/libU77/access_.c | 80 + gcc/f/runtime/libU77/acconfig.h | 2 + gcc/f/runtime/libU77/alarm_.c | 59 + gcc/f/runtime/libU77/bes.c | 46 + gcc/f/runtime/libU77/chdir_.c | 57 + gcc/f/runtime/libU77/chmod_.c | 79 + gcc/f/runtime/libU77/config.h.in | 73 + gcc/f/runtime/libU77/configure | 1758 ++ gcc/f/runtime/libU77/configure.in | 111 + gcc/f/runtime/libU77/ctime_.c | 57 + gcc/f/runtime/libU77/date_.c | 39 + gcc/f/runtime/libU77/dbes.c | 46 + gcc/f/runtime/libU77/dtime_.c | 82 + gcc/f/runtime/libU77/etime_.c | 78 + gcc/f/runtime/libU77/fdate_.c | 53 + gcc/f/runtime/libU77/fgetc_.c | 70 + gcc/f/runtime/libU77/flush1_.c | 46 + gcc/f/runtime/libU77/fnum_.c | 38 + gcc/f/runtime/libU77/fputc_.c | 65 + gcc/f/runtime/libU77/fstat_.c | 71 + gcc/f/runtime/libU77/gerror_.c | 49 + gcc/f/runtime/libU77/getcwd_.c | 98 + gcc/f/runtime/libU77/getgid_.c | 35 + gcc/f/runtime/libU77/getlog_.c | 62 + gcc/f/runtime/libU77/getpid_.c | 35 + gcc/f/runtime/libU77/getuid_.c | 35 + gcc/f/runtime/libU77/gmtime_.c | 54 + gcc/f/runtime/libU77/hostnm_.c | 48 + gcc/f/runtime/libU77/idate_.c | 57 + gcc/f/runtime/libU77/ierrno_.c | 32 + gcc/f/runtime/libU77/irand_.c | 57 + gcc/f/runtime/libU77/isatty_.c | 44 + gcc/f/runtime/libU77/itime_.c | 51 + gcc/f/runtime/libU77/kill_.c | 37 + gcc/f/runtime/libU77/link_.c | 58 + gcc/f/runtime/libU77/lnblnk_.c | 35 + gcc/f/runtime/libU77/lstat_.c | 86 + gcc/f/runtime/libU77/ltime_.c | 54 + gcc/f/runtime/libU77/mclock_.c | 47 + gcc/f/runtime/libU77/perror_.c | 48 + gcc/f/runtime/libU77/rand_.c | 54 + gcc/f/runtime/libU77/rename_.c | 53 + gcc/f/runtime/libU77/secnds_.c | 51 + gcc/f/runtime/libU77/second_.c | 26 + gcc/f/runtime/libU77/sleep_.c | 37 + gcc/f/runtime/libU77/srand_.c | 37 + gcc/f/runtime/libU77/stat_.c | 79 + gcc/f/runtime/libU77/symlnk_.c | 62 + gcc/f/runtime/libU77/system_clock_.c | 64 + gcc/f/runtime/libU77/time_.c | 46 + gcc/f/runtime/libU77/ttynam_.c | 57 + gcc/f/runtime/libU77/u77-test.f | 178 + gcc/f/runtime/libU77/umask_.c | 34 + gcc/f/runtime/libU77/unlink_.c | 55 + gcc/f/runtime/libU77/vxtidate_.c | 55 + gcc/f/runtime/libU77/vxttime_.c | 54 + gcc/f/runtime/permission.netlib | 23 + gcc/f/runtime/readme.netlib | 585 + gcc/f/src.c | 436 + gcc/f/src.h | 144 + gcc/f/st.c | 554 + gcc/f/st.h | 81 + gcc/f/sta.c | 1993 ++ gcc/f/sta.h | 116 + gcc/f/stb.c | 25192 +++++++++++++++++++++++++ gcc/f/stb.h | 253 + gcc/f/stc.c | 13895 ++++++++++++++ gcc/f/stc.h | 360 + gcc/f/std.c | 6739 +++++++ gcc/f/std.h | 298 + gcc/f/ste.c | 5414 ++++++ gcc/f/ste.h | 168 + gcc/f/storag.c | 573 + gcc/f/storag.h | 167 + gcc/f/stp.c | 59 + gcc/f/stp.h | 508 + gcc/f/str-1t.fin | 135 + gcc/f/str-2t.fin | 60 + gcc/f/str-fo.fin | 55 + gcc/f/str-io.fin | 43 + gcc/f/str-nq.fin | 55 + gcc/f/str-op.fin | 57 + gcc/f/str-ot.fin | 47 + gcc/f/str.c | 217 + gcc/f/str.h | 85 + gcc/f/sts.c | 271 + gcc/f/sts.h | 89 + gcc/f/stt.c | 1034 + gcc/f/stt.h | 218 + gcc/f/stu.c | 1161 ++ gcc/f/stu.h | 69 + gcc/f/stv.c | 66 + gcc/f/stv.h | 165 + gcc/f/stw.c | 428 + gcc/f/stw.h | 184 + gcc/f/symbol.c | 1469 ++ gcc/f/symbol.def | 654 + gcc/f/symbol.h | 289 + gcc/f/target.c | 2487 +++ gcc/f/target.h | 1865 ++ gcc/f/tconfig.j | 27 + gcc/f/tm.j | 27 + gcc/f/top.c | 926 + gcc/f/top.h | 261 + gcc/f/tree.j | 28 + gcc/f/type.c | 107 + gcc/f/type.h | 64 + gcc/f/where.c | 542 + gcc/f/where.h | 138 + gcc/f/zzz.c | 56 + gcc/f/zzz.h | 35 + 371 files changed, 211175 insertions(+) create mode 100644 gcc/f/BUGS create mode 100644 gcc/f/ChangeLog create mode 100644 gcc/f/INSTALL create mode 100644 gcc/f/Make-lang.in create mode 100644 gcc/f/Makefile.in create mode 100644 gcc/f/NEWS create mode 100644 gcc/f/README create mode 100644 gcc/f/assert.j create mode 100644 gcc/f/bad.c create mode 100644 gcc/f/bad.def create mode 100644 gcc/f/bad.h create mode 100644 gcc/f/bit.c create mode 100644 gcc/f/bit.h create mode 100644 gcc/f/bld-op.def create mode 100644 gcc/f/bld.c create mode 100644 gcc/f/bld.h create mode 100644 gcc/f/bugs.texi create mode 100644 gcc/f/bugs0.texi create mode 100644 gcc/f/com-rt.def create mode 100644 gcc/f/com.c create mode 100644 gcc/f/com.h create mode 100644 gcc/f/config-lang.in create mode 100644 gcc/f/config.j create mode 100644 gcc/f/convert.j create mode 100644 gcc/f/data.c create mode 100644 gcc/f/data.h create mode 100644 gcc/f/equiv.c create mode 100644 gcc/f/equiv.h create mode 100644 gcc/f/expr.c create mode 100644 gcc/f/expr.h create mode 100644 gcc/f/fini.c create mode 100644 gcc/f/flags.j create mode 100644 gcc/f/g77.1 create mode 100644 gcc/f/g77.c create mode 100644 gcc/f/g77.texi create mode 100644 gcc/f/gbe/2.7.2.2.diff create mode 100644 gcc/f/gbe/README create mode 100644 gcc/f/glimits.j create mode 100644 gcc/f/global.c create mode 100644 gcc/f/global.h create mode 100644 gcc/f/hconfig.j create mode 100644 gcc/f/implic.c create mode 100644 gcc/f/implic.h create mode 100644 gcc/f/info-b.def create mode 100644 gcc/f/info-k.def create mode 100644 gcc/f/info-w.def create mode 100644 gcc/f/info.c create mode 100644 gcc/f/info.h create mode 100644 gcc/f/input.j create mode 100644 gcc/f/install.texi create mode 100644 gcc/f/install0.texi create mode 100644 gcc/f/intdoc.c create mode 100644 gcc/f/intdoc.h create mode 100644 gcc/f/intdoc.texi create mode 100644 gcc/f/intrin.c create mode 100644 gcc/f/intrin.def create mode 100644 gcc/f/intrin.h create mode 100644 gcc/f/lab.c create mode 100644 gcc/f/lab.h create mode 100644 gcc/f/lang-options.h create mode 100644 gcc/f/lang-specs.h create mode 100644 gcc/f/lex.c create mode 100644 gcc/f/lex.h create mode 100644 gcc/f/malloc.c create mode 100644 gcc/f/malloc.h create mode 100644 gcc/f/name.c create mode 100644 gcc/f/name.h create mode 100644 gcc/f/news.texi create mode 100644 gcc/f/news0.texi create mode 100644 gcc/f/parse.c create mode 100644 gcc/f/proj.c create mode 100644 gcc/f/proj.h create mode 100644 gcc/f/rtl.j create mode 100644 gcc/f/runtime/ChangeLog create mode 100644 gcc/f/runtime/Makefile.in create mode 100644 gcc/f/runtime/README create mode 100644 gcc/f/runtime/TODO create mode 100644 gcc/f/runtime/changes.netlib create mode 100755 gcc/f/runtime/configure create mode 100644 gcc/f/runtime/configure.in create mode 100644 gcc/f/runtime/disclaimer.netlib create mode 100644 gcc/f/runtime/f2c.h.in create mode 100644 gcc/f/runtime/f2cext.c create mode 100644 gcc/f/runtime/libF77/F77_aloc.c create mode 100644 gcc/f/runtime/libF77/Makefile.in create mode 100644 gcc/f/runtime/libF77/Notice create mode 100644 gcc/f/runtime/libF77/README.netlib create mode 100644 gcc/f/runtime/libF77/Version.c create mode 100644 gcc/f/runtime/libF77/abort_.c create mode 100644 gcc/f/runtime/libF77/c_abs.c create mode 100644 gcc/f/runtime/libF77/c_cos.c create mode 100644 gcc/f/runtime/libF77/c_div.c create mode 100644 gcc/f/runtime/libF77/c_exp.c create mode 100644 gcc/f/runtime/libF77/c_log.c create mode 100644 gcc/f/runtime/libF77/c_sin.c create mode 100644 gcc/f/runtime/libF77/c_sqrt.c create mode 100644 gcc/f/runtime/libF77/cabs.c create mode 100644 gcc/f/runtime/libF77/d_abs.c create mode 100644 gcc/f/runtime/libF77/d_acos.c create mode 100644 gcc/f/runtime/libF77/d_asin.c create mode 100644 gcc/f/runtime/libF77/d_atan.c create mode 100644 gcc/f/runtime/libF77/d_atn2.c create mode 100644 gcc/f/runtime/libF77/d_cnjg.c create mode 100644 gcc/f/runtime/libF77/d_cos.c create mode 100644 gcc/f/runtime/libF77/d_cosh.c create mode 100644 gcc/f/runtime/libF77/d_dim.c create mode 100644 gcc/f/runtime/libF77/d_exp.c create mode 100644 gcc/f/runtime/libF77/d_imag.c create mode 100644 gcc/f/runtime/libF77/d_int.c create mode 100644 gcc/f/runtime/libF77/d_lg10.c create mode 100644 gcc/f/runtime/libF77/d_log.c create mode 100644 gcc/f/runtime/libF77/d_mod.c create mode 100644 gcc/f/runtime/libF77/d_nint.c create mode 100644 gcc/f/runtime/libF77/d_prod.c create mode 100644 gcc/f/runtime/libF77/d_sign.c create mode 100644 gcc/f/runtime/libF77/d_sin.c create mode 100644 gcc/f/runtime/libF77/d_sinh.c create mode 100644 gcc/f/runtime/libF77/d_sqrt.c create mode 100644 gcc/f/runtime/libF77/d_tan.c create mode 100644 gcc/f/runtime/libF77/d_tanh.c create mode 100644 gcc/f/runtime/libF77/derf_.c create mode 100644 gcc/f/runtime/libF77/derfc_.c create mode 100644 gcc/f/runtime/libF77/dtime_.c create mode 100644 gcc/f/runtime/libF77/ef1asc_.c create mode 100644 gcc/f/runtime/libF77/ef1cmc_.c create mode 100644 gcc/f/runtime/libF77/erf_.c create mode 100644 gcc/f/runtime/libF77/erfc_.c create mode 100644 gcc/f/runtime/libF77/etime_.c create mode 100644 gcc/f/runtime/libF77/exit_.c create mode 100644 gcc/f/runtime/libF77/f2ch.add create mode 100644 gcc/f/runtime/libF77/getarg_.c create mode 100644 gcc/f/runtime/libF77/getenv_.c create mode 100644 gcc/f/runtime/libF77/h_abs.c create mode 100644 gcc/f/runtime/libF77/h_dim.c create mode 100644 gcc/f/runtime/libF77/h_dnnt.c create mode 100644 gcc/f/runtime/libF77/h_indx.c create mode 100644 gcc/f/runtime/libF77/h_len.c create mode 100644 gcc/f/runtime/libF77/h_mod.c create mode 100644 gcc/f/runtime/libF77/h_nint.c create mode 100644 gcc/f/runtime/libF77/h_sign.c create mode 100644 gcc/f/runtime/libF77/hl_ge.c create mode 100644 gcc/f/runtime/libF77/hl_gt.c create mode 100644 gcc/f/runtime/libF77/hl_le.c create mode 100644 gcc/f/runtime/libF77/hl_lt.c create mode 100644 gcc/f/runtime/libF77/i_abs.c create mode 100644 gcc/f/runtime/libF77/i_dim.c create mode 100644 gcc/f/runtime/libF77/i_dnnt.c create mode 100644 gcc/f/runtime/libF77/i_indx.c create mode 100644 gcc/f/runtime/libF77/i_len.c create mode 100644 gcc/f/runtime/libF77/i_mod.c create mode 100644 gcc/f/runtime/libF77/i_nint.c create mode 100644 gcc/f/runtime/libF77/i_sign.c create mode 100644 gcc/f/runtime/libF77/iargc_.c create mode 100644 gcc/f/runtime/libF77/l_ge.c create mode 100644 gcc/f/runtime/libF77/l_gt.c create mode 100644 gcc/f/runtime/libF77/l_le.c create mode 100644 gcc/f/runtime/libF77/l_lt.c create mode 100644 gcc/f/runtime/libF77/lbitbits.c create mode 100644 gcc/f/runtime/libF77/lbitshft.c create mode 100644 gcc/f/runtime/libF77/main.c create mode 100644 gcc/f/runtime/libF77/makefile.netlib create mode 100644 gcc/f/runtime/libF77/pow_ci.c create mode 100644 gcc/f/runtime/libF77/pow_dd.c create mode 100644 gcc/f/runtime/libF77/pow_di.c create mode 100644 gcc/f/runtime/libF77/pow_hh.c create mode 100644 gcc/f/runtime/libF77/pow_ii.c create mode 100644 gcc/f/runtime/libF77/pow_qq.c create mode 100644 gcc/f/runtime/libF77/pow_ri.c create mode 100644 gcc/f/runtime/libF77/pow_zi.c create mode 100644 gcc/f/runtime/libF77/pow_zz.c create mode 100644 gcc/f/runtime/libF77/qbitbits.c create mode 100644 gcc/f/runtime/libF77/qbitshft.c create mode 100644 gcc/f/runtime/libF77/r_abs.c create mode 100644 gcc/f/runtime/libF77/r_acos.c create mode 100644 gcc/f/runtime/libF77/r_asin.c create mode 100644 gcc/f/runtime/libF77/r_atan.c create mode 100644 gcc/f/runtime/libF77/r_atn2.c create mode 100644 gcc/f/runtime/libF77/r_cnjg.c create mode 100644 gcc/f/runtime/libF77/r_cos.c create mode 100644 gcc/f/runtime/libF77/r_cosh.c create mode 100644 gcc/f/runtime/libF77/r_dim.c create mode 100644 gcc/f/runtime/libF77/r_exp.c create mode 100644 gcc/f/runtime/libF77/r_imag.c create mode 100644 gcc/f/runtime/libF77/r_int.c create mode 100644 gcc/f/runtime/libF77/r_lg10.c create mode 100644 gcc/f/runtime/libF77/r_log.c create mode 100644 gcc/f/runtime/libF77/r_mod.c create mode 100644 gcc/f/runtime/libF77/r_nint.c create mode 100644 gcc/f/runtime/libF77/r_sign.c create mode 100644 gcc/f/runtime/libF77/r_sin.c create mode 100644 gcc/f/runtime/libF77/r_sinh.c create mode 100644 gcc/f/runtime/libF77/r_sqrt.c create mode 100644 gcc/f/runtime/libF77/r_tan.c create mode 100644 gcc/f/runtime/libF77/r_tanh.c create mode 100644 gcc/f/runtime/libF77/s_cat.c create mode 100644 gcc/f/runtime/libF77/s_cmp.c create mode 100644 gcc/f/runtime/libF77/s_copy.c create mode 100644 gcc/f/runtime/libF77/s_paus.c create mode 100644 gcc/f/runtime/libF77/s_rnge.c create mode 100644 gcc/f/runtime/libF77/s_stop.c create mode 100644 gcc/f/runtime/libF77/sig_die.c create mode 100644 gcc/f/runtime/libF77/signal1.h create mode 100644 gcc/f/runtime/libF77/signal1.h0 create mode 100644 gcc/f/runtime/libF77/signal_.c create mode 100644 gcc/f/runtime/libF77/system_.c create mode 100644 gcc/f/runtime/libF77/z_abs.c create mode 100644 gcc/f/runtime/libF77/z_cos.c create mode 100644 gcc/f/runtime/libF77/z_div.c create mode 100644 gcc/f/runtime/libF77/z_exp.c create mode 100644 gcc/f/runtime/libF77/z_log.c create mode 100644 gcc/f/runtime/libF77/z_sin.c create mode 100644 gcc/f/runtime/libF77/z_sqrt.c create mode 100644 gcc/f/runtime/libI77/Makefile.in create mode 100644 gcc/f/runtime/libI77/Notice create mode 100644 gcc/f/runtime/libI77/README.netlib create mode 100644 gcc/f/runtime/libI77/Version.c create mode 100644 gcc/f/runtime/libI77/backspace.c create mode 100644 gcc/f/runtime/libI77/close.c create mode 100644 gcc/f/runtime/libI77/dfe.c create mode 100644 gcc/f/runtime/libI77/dolio.c create mode 100644 gcc/f/runtime/libI77/due.c create mode 100644 gcc/f/runtime/libI77/endfile.c create mode 100644 gcc/f/runtime/libI77/err.c create mode 100644 gcc/f/runtime/libI77/f2ch.add create mode 100644 gcc/f/runtime/libI77/fio.h create mode 100644 gcc/f/runtime/libI77/fmt.c create mode 100644 gcc/f/runtime/libI77/fmt.h create mode 100644 gcc/f/runtime/libI77/fmtlib.c create mode 100644 gcc/f/runtime/libI77/fp.h create mode 100644 gcc/f/runtime/libI77/ftell_.c create mode 100644 gcc/f/runtime/libI77/iio.c create mode 100644 gcc/f/runtime/libI77/ilnw.c create mode 100644 gcc/f/runtime/libI77/inquire.c create mode 100644 gcc/f/runtime/libI77/lio.h create mode 100644 gcc/f/runtime/libI77/lread.c create mode 100644 gcc/f/runtime/libI77/lwrite.c create mode 100644 gcc/f/runtime/libI77/makefile.netlib create mode 100644 gcc/f/runtime/libI77/open.c create mode 100644 gcc/f/runtime/libI77/rawio.h create mode 100644 gcc/f/runtime/libI77/rdfmt.c create mode 100644 gcc/f/runtime/libI77/rewind.c create mode 100644 gcc/f/runtime/libI77/rsfe.c create mode 100644 gcc/f/runtime/libI77/rsli.c create mode 100644 gcc/f/runtime/libI77/rsne.c create mode 100644 gcc/f/runtime/libI77/sfe.c create mode 100644 gcc/f/runtime/libI77/sue.c create mode 100644 gcc/f/runtime/libI77/typesize.c create mode 100644 gcc/f/runtime/libI77/uio.c create mode 100644 gcc/f/runtime/libI77/util.c create mode 100644 gcc/f/runtime/libI77/wref.c create mode 100644 gcc/f/runtime/libI77/wrtfmt.c create mode 100644 gcc/f/runtime/libI77/wsfe.c create mode 100644 gcc/f/runtime/libI77/wsle.c create mode 100644 gcc/f/runtime/libI77/wsne.c create mode 100644 gcc/f/runtime/libI77/xwsne.c create mode 100644 gcc/f/runtime/libU77/COPYING.LIB create mode 100644 gcc/f/runtime/libU77/Makefile.in create mode 100644 gcc/f/runtime/libU77/PROJECTS create mode 100644 gcc/f/runtime/libU77/README create mode 100644 gcc/f/runtime/libU77/Version.c create mode 100644 gcc/f/runtime/libU77/access_.c create mode 100644 gcc/f/runtime/libU77/acconfig.h create mode 100644 gcc/f/runtime/libU77/alarm_.c create mode 100644 gcc/f/runtime/libU77/bes.c create mode 100644 gcc/f/runtime/libU77/chdir_.c create mode 100644 gcc/f/runtime/libU77/chmod_.c create mode 100644 gcc/f/runtime/libU77/config.h.in create mode 100755 gcc/f/runtime/libU77/configure create mode 100644 gcc/f/runtime/libU77/configure.in create mode 100644 gcc/f/runtime/libU77/ctime_.c create mode 100644 gcc/f/runtime/libU77/date_.c create mode 100644 gcc/f/runtime/libU77/dbes.c create mode 100644 gcc/f/runtime/libU77/dtime_.c create mode 100644 gcc/f/runtime/libU77/etime_.c create mode 100644 gcc/f/runtime/libU77/fdate_.c create mode 100644 gcc/f/runtime/libU77/fgetc_.c create mode 100644 gcc/f/runtime/libU77/flush1_.c create mode 100644 gcc/f/runtime/libU77/fnum_.c create mode 100644 gcc/f/runtime/libU77/fputc_.c create mode 100644 gcc/f/runtime/libU77/fstat_.c create mode 100644 gcc/f/runtime/libU77/gerror_.c create mode 100644 gcc/f/runtime/libU77/getcwd_.c create mode 100644 gcc/f/runtime/libU77/getgid_.c create mode 100644 gcc/f/runtime/libU77/getlog_.c create mode 100644 gcc/f/runtime/libU77/getpid_.c create mode 100644 gcc/f/runtime/libU77/getuid_.c create mode 100644 gcc/f/runtime/libU77/gmtime_.c create mode 100644 gcc/f/runtime/libU77/hostnm_.c create mode 100644 gcc/f/runtime/libU77/idate_.c create mode 100644 gcc/f/runtime/libU77/ierrno_.c create mode 100644 gcc/f/runtime/libU77/irand_.c create mode 100644 gcc/f/runtime/libU77/isatty_.c create mode 100644 gcc/f/runtime/libU77/itime_.c create mode 100644 gcc/f/runtime/libU77/kill_.c create mode 100644 gcc/f/runtime/libU77/link_.c create mode 100644 gcc/f/runtime/libU77/lnblnk_.c create mode 100644 gcc/f/runtime/libU77/lstat_.c create mode 100644 gcc/f/runtime/libU77/ltime_.c create mode 100644 gcc/f/runtime/libU77/mclock_.c create mode 100644 gcc/f/runtime/libU77/perror_.c create mode 100644 gcc/f/runtime/libU77/rand_.c create mode 100644 gcc/f/runtime/libU77/rename_.c create mode 100644 gcc/f/runtime/libU77/secnds_.c create mode 100644 gcc/f/runtime/libU77/second_.c create mode 100644 gcc/f/runtime/libU77/sleep_.c create mode 100644 gcc/f/runtime/libU77/srand_.c create mode 100644 gcc/f/runtime/libU77/stat_.c create mode 100644 gcc/f/runtime/libU77/symlnk_.c create mode 100644 gcc/f/runtime/libU77/system_clock_.c create mode 100644 gcc/f/runtime/libU77/time_.c create mode 100644 gcc/f/runtime/libU77/ttynam_.c create mode 100644 gcc/f/runtime/libU77/u77-test.f create mode 100644 gcc/f/runtime/libU77/umask_.c create mode 100644 gcc/f/runtime/libU77/unlink_.c create mode 100644 gcc/f/runtime/libU77/vxtidate_.c create mode 100644 gcc/f/runtime/libU77/vxttime_.c create mode 100644 gcc/f/runtime/permission.netlib create mode 100644 gcc/f/runtime/readme.netlib create mode 100644 gcc/f/src.c create mode 100644 gcc/f/src.h create mode 100644 gcc/f/st.c create mode 100644 gcc/f/st.h create mode 100644 gcc/f/sta.c create mode 100644 gcc/f/sta.h create mode 100644 gcc/f/stb.c create mode 100644 gcc/f/stb.h create mode 100644 gcc/f/stc.c create mode 100644 gcc/f/stc.h create mode 100644 gcc/f/std.c create mode 100644 gcc/f/std.h create mode 100644 gcc/f/ste.c create mode 100644 gcc/f/ste.h create mode 100644 gcc/f/storag.c create mode 100644 gcc/f/storag.h create mode 100644 gcc/f/stp.c create mode 100644 gcc/f/stp.h create mode 100644 gcc/f/str-1t.fin create mode 100644 gcc/f/str-2t.fin create mode 100644 gcc/f/str-fo.fin create mode 100644 gcc/f/str-io.fin create mode 100644 gcc/f/str-nq.fin create mode 100644 gcc/f/str-op.fin create mode 100644 gcc/f/str-ot.fin create mode 100644 gcc/f/str.c create mode 100644 gcc/f/str.h create mode 100644 gcc/f/sts.c create mode 100644 gcc/f/sts.h create mode 100644 gcc/f/stt.c create mode 100644 gcc/f/stt.h create mode 100644 gcc/f/stu.c create mode 100644 gcc/f/stu.h create mode 100644 gcc/f/stv.c create mode 100644 gcc/f/stv.h create mode 100644 gcc/f/stw.c create mode 100644 gcc/f/stw.h create mode 100644 gcc/f/symbol.c create mode 100644 gcc/f/symbol.def create mode 100644 gcc/f/symbol.h create mode 100644 gcc/f/target.c create mode 100644 gcc/f/target.h create mode 100644 gcc/f/tconfig.j create mode 100644 gcc/f/tm.j create mode 100644 gcc/f/top.c create mode 100644 gcc/f/top.h create mode 100644 gcc/f/tree.j create mode 100644 gcc/f/type.c create mode 100644 gcc/f/type.h create mode 100644 gcc/f/where.c create mode 100644 gcc/f/where.h create mode 100644 gcc/f/zzz.c create mode 100644 gcc/f/zzz.h diff --git a/gcc/f/BUGS b/gcc/f/BUGS new file mode 100644 index 000000000000..ebeaedb7b46d --- /dev/null +++ b/gcc/f/BUGS @@ -0,0 +1,198 @@ +This file lists known bugs in the GNU Fortran compiler. Copyright (C) +1995, 1996 Free Software Foundation, Inc. You may copy, distribute, +and modify it freely as long as you preserve this copyright notice and +permission notice. + +Bugs in GNU Fortran +******************* + + This section identifies bugs that `g77' *users* might run into. +This includes bugs that are actually in the `gcc' back end (GBE) or in +`libf2c', because those sets of code are at least somewhat under the +control of (and necessarily intertwined with) `g77', so it isn't worth +separating them out. + + For information on bugs that might afflict people who configure, +port, build, and install `g77', *Note Problems Installing::. + + * Work is needed on the `SIGNAL()' intrinsic to ensure that pointers + and integers are properly handled on all targets, including 64-bit + machines. + + * When using `-fugly-comma', `g77' assumes an extra `%VAL(0)' + argument is to be passed to intrinsics taking no arguments, such + as `IARGC()', which in turn reject such a call. Although this has + been worked around for 0.5.18 due to changes in the handling of + intrinsics, `g77' needs to do the ugly-argument-appending trick + only for external-function invocation, as this would probably be + more consistent with compilers that default to using that trick. + + * Something about `g77''s straightforward handling of label + references and definitions sometimes prevents the GBE from + unrolling loops. Until this is solved, try inserting or removing + `CONTINUE' statements as the terminal statement, using the `END DO' + form instead, and so on. (Probably improved, but not wholly + fixed, in 0.5.21.) + + * The `g77' command itself should more faithfully process options + the way the `gcc' command does. For example, `gcc' accepts + abbreviated forms of long options, `g77' generally doesn't. + + * Some confusion in diagnostics concerning failing `INCLUDE' + statements from within `INCLUDE''d or `#include''d files. + + * `g77' assumes that `INTEGER(KIND=1)' constants range from `-2**31' + to `2**31-1' (the range for two's-complement 32-bit values), + instead of determining their range from the actual range of the + type for the configuration (and, someday, for the constant). + + Further, it generally doesn't implement the handling of constants + very well in that it makes assumptions about the configuration + that it no longer makes regarding variables (types). + + Included with this item is the fact that `g77' doesn't recognize + that, on IEEE-754/854-compliant systems, `0./0.' should produce a + NaN and no warning instead of the value `0.' and a warning. This + is to be fixed in version 0.6, when `g77' will use the `gcc' back + end's constant-handling mechanisms to replace its own. + + * `g77' uses way too much memory and CPU time to process large + aggregate areas having any initialized elements. + + For example, `REAL A(1000000)' followed by `DATA A(1)/1/' takes up + way too much time and space, including the size of the generated + assembler file. This is to be mitigated somewhat in version 0.6. + + Version 0.5.18 improves cases like this--specifically, cases of + *sparse* initialization that leave large, contiguous areas + uninitialized--significantly. However, even with the + improvements, these cases still require too much memory and CPU + time. + + (Version 0.5.18 also improves cases where the initial values are + zero to a much greater degree, so if the above example ends with + `DATA A(1)/0/', the compile-time performance will be about as good + as it will ever get, aside from unrelated improvements to the + compiler.) + + Note that `g77' does display a warning message to notify the user + before the compiler appears to hang. *Note Initialization of + Large Aggregate Areas: Large Initialization, for information on + how to change the point at which `g77' decides to issue this + warning. + + * `g77' doesn't emit variable and array members of common blocks for + use with a debugger (the `-g' command-line option). The code is + present to do this, but doesn't work with at least one debug + format--perhaps it works with others. And it turns out there's a + similar bug for local equivalence areas, so that has been disabled + as well. + + As of Version 0.5.19, a temporary kludge solution is provided + whereby some rudimentary information on a member is written as a + string that is the member's value as a character string. + + *Note Options for Code Generation Conventions: Code Gen Options, + for information on the `-fdebug-kludge' option. + + * When debugging, after starting up the debugger but before being + able to see the source code for the main program unit, the user + must currently set a breakpoint at `MAIN__' (or `MAIN___' or + `MAIN_' if `MAIN__' doesn't exist) and run the program until it + hits the breakpoint. At that point, the main program unit is + activated and about to execute its first executable statement, but + that's the state in which the debugger should start up, as is the + case for languages like C. + + * Debugging `g77'-compiled code using debuggers other than `gdb' is + likely not to work. + + Getting `g77' and `gdb' to work together is a known + problem--getting `g77' to work properly with other debuggers, for + which source code often is unavailable to `g77' developers, seems + like a much larger, unknown problem, and is a lower priority than + making `g77' and `gdb' work together properly. + + On the other hand, information about problems other debuggers have + with `g77' output might make it easier to properly fix `g77', and + perhaps even improve `gdb', so it is definitely welcome. Such + information might even lead to all relevant products working + together properly sooner. + + * `g77' currently inserts needless padding for things like `COMMON + A,IPAD' where `A' is `CHARACTER*1' and `IPAD' is `INTEGER(KIND=1)' + on machines like x86, because the back end insists that `IPAD' be + aligned to a 4-byte boundary, but the processor has no such + requirement (though it's good for performance). + + It is possible that this is not a real bug, and could be considered + a performance feature, but it might be important to provide the + ability to Fortran code to specify minimum padding for aggregate + areas such as common blocks--and, certainly, there is the + potential, with the current setup, for interface differences in + the way such areas are laid out between `g77' and other compilers. + + * Some crashes occur when compiling under Solaris on x86 machines. + + Nothing has been heard about any such problems for some time, so + this is considering a closed item as of 0.5.20. Please submit any + bug reports pertinent to `g77''s support for Solaris/x86 systems. + + * RS/6000 support is not complete as of the gcc 2.6.3 back end. The + 2.7.0 back end appears to fix this problem, or at least mitigate + it significantly, but there is at least one known problem that is + likely to be a code-generation bug in `gcc-2.7.0' plus + `g77-0.5.16'. This problem shows up only when compiling the + Fortran program with `-O'. + + Nothing has been heard about any RS/6000 problems for some time, + so this is considering a closed item as of 0.5.20. Please submit + any bug reports pertinent to `g77''s support for RS/6000 systems. + + * SGI support is known to be a bit buggy. The known problem shows + up only when compiling the Fortran program with `-O'. + + It is possible these problems have all been fixed in 0.5.20 by + emulating complex arithmetic in the front end. Please submit any + bug reports pertinent to `g77''s support for SGI systems. + + * `g77' doesn't work perfectly on 64-bit configurations such as the + Alpha. This problem is expected to be largely resolved as of + version 0.5.20, and further addressed by 0.5.21. Version 0.6 + should solve most or all related problems (such as 64-bit machines + other than Digital Semiconductor ("DEC") Alphas). + + One known bug that causes a compile-time crash occurs when + compiling code such as the following with optimization: + + SUBROUTINE CRASH (TEMP) + INTEGER*2 HALF(2) + REAL TEMP + HALF(1) = NINT (TEMP) + END + + It is expected that a future version of `g77' will have a fix for + this problem, almost certainly by the time `g77' supports the + forthcoming version 2.8.0 of `gcc'. + + * Maintainers of gcc report that the back end definitely has "broken" + support for `COMPLEX' types. Based on their input, it seems many + of the problems affect only the more-general facilities for gcc's + `__complex__' type, such as `__complex__ int' (where the real and + imaginary parts are integers) that GNU Fortran does not use. + + Version 0.5.20 of `g77' works around this problem by not using the + back end's support for `COMPLEX'. The new option + `-fno-emulate-complex' avoids the work-around, reverting to using + the same "broken" mechanism as that used by versions of `g77' + prior to 0.5.20. + + * There seem to be some problems with passing constants, and perhaps + general expressions (other than simple variables/arrays), to + procedures when compiling on some systems (such as i386) with + `-fPIC', as in when compiling for ELF targets. The symptom is + that the assembler complains about invalid opcodes. More + investigation is needed, but the problem is almost certainly in + the gcc back end, and it apparently occurs only when compiling + sufficiently complicated functions *without* the `-O' option. + diff --git a/gcc/f/ChangeLog b/gcc/f/ChangeLog new file mode 100644 index 000000000000..38546900343d --- /dev/null +++ b/gcc/f/ChangeLog @@ -0,0 +1,3721 @@ +Mon Aug 11 21:19:22 1997 Craig Burley + + * Make-lang.in ($(RUNTIMESTAGESTUFF)): Add + f/runtime/stamp-lib. + +Mon Aug 11 01:52:03 1997 Craig Burley + + * com.c (ffecom_build_complex_constant_): Go with the + new build_complex() approach used in gcc-2.8. + + * com.c (ffecom_sym_transform_): Don't set + DECL_IN_SYSTEM_HEADER for a tree node that isn't + a VAR_DECL, which happens when var is in common! + + * com.c (ffecom_expr_intrinsic_) (case FFEINTRIN_impALARM): + No need to test codegen_imp -- there's only one valid here. + + * intrin.def (FFEINTRIN_impALARM): Specify `Status' argument + as write-only. + +Fri Aug 8 05:40:23 1997 Craig Burley + + Substantial changes to accommodate distinctions among + run-time routines that support intrinsics, and between + routines that compute and return the same type vs. those + that compute one type and return another (or `void'): + * com-rt.def: Specify new return type REAL_F2C_ instead + of many DOUBLE_, COMPLEX_F2C_ instead of COMPLEX_, and + so on. + Clear up the *BES* routines "once and for all". + * com.c: New return types. + (ffecom_convert_narrow_, ffecom_convert_widen_): + New functions that are "safe" variants of convert(), + to catch errors that ffecom_expr_intrinsic_() now + no longer catches. + (ffecom_arglist_expr_): Ensure arguments are not + converted to narrower types. + (ffecom_call_): Ensure return value is not converted + to a wider type. + (ffecom_char_args_): Use new ffeintrin_gfrt_direct() + routine. + (ffecom_expr_intrinsic_): Simplify how run-time + routine is selected (via `gfrt' only now; lose the + redundant `ix' variable). + Eliminate the `library' label; any code that doesn't + return directly just `break's out now with `gfrt' + set appropriately. + Set `gfrt' to default choice initially, either a + fast direct form or, if not available, a slower + indirect-callable form. + (ffecom_make_gfrt_): No longer need to do special + check for complex; it's built into the new return-type + regime. + (ffecom_ptr_to_expr): Use new ffeintrin_gfrt_indirect() + routine. + * intrin.c, intrin.h: `gfrt' field replaced with three fields, + so it is easier to provide faster direct-callable and + GNU-convention indirect-callable routines in the future. + DEFIMP macro adjusted accordingly, along with all its uses. + (ffeintrin_gfrt_direct): New function. + (ffeintrin_gfrt_indirect): Ditto. + (ffeintrin_is_actualarg): If `-fno-f2c' is in effect, + require a GNU-callable version of intrinsic instead of + an f2c-callable version, so indirect calling is still checked. + * intrin.def: Replace one GFRT field with the three new fields, + as appropriate for each DEFIMP intrinsic. + + * com.c (ffecom_stabilize_aggregate_, + ffecom_convert_to_complex_): Make these `static'. + +Thu Aug 7 11:24:34 1997 Craig Burley + + Provide means for front end to determine actual + "standard" return type for an intrinsic if it is + passed as an actual argument: + * com.h, com.c (ffecom_gfrt_basictype, + ffecom_gfrt_kindtype): New functions. + (ffecom_gfrt_kind_type_): Replaced with new function. + All callers updated. + (ffecom_make_gfrt_): No longer need do anything + with kind type. + + * intrin.c (ffeintrin_basictype, ffeintrin_kindtype): + Now returns correct type info for specific intrinsic + (based on type of run-time-library implementation). + +Wed Aug 6 23:08:46 1997 Craig Burley + + * global.c (ffeglobal_ref_progunit_): Don't reset + number of arguments just due to new type info, + so useful warnings can be issued. + +1997-08-06 Dave Love + + * intrin.def: Fix IDATE_vxt argument order. + * intdoc.h: Likewise. + +Thu Jul 31 22:22:03 1997 Craig Burley + + * global.c (ffeglobal_proc_ref_arg): If REF/DESCR + disagreement, DESCR is CHARACTER, and types disagree, + pretend the argsummary agrees so the message ends up + being about type disagreement. + (ffeglobal_proc_def_arg): Ditto. + + * expr.c (ffeexpr_token_first_rhs_3_): Set info for LABTOK + to NONE of everything, to avoid misdiagnosing filewide + usage of alternate returns. + +Sun Jul 20 23:07:47 1997 Craig Burley + + * com.c (ffecom_sym_transform_): If type gets set + to error_mark_node, just return that for transformed symbol. + (ffecom_member_phase2_): If type gets set to error_mark_node, + just return. + (ffecom_check_size_overflow_): Add `dummy' argument to + flag that type is for a dummy, update all callers. + +Sun Jul 13 17:40:53 1997 Craig Burley + + Fix 970712-1.f: + * where.c (ffewhere_set_from_track): If start point + is too large, just use initial start point. 0.6 should + fix all this properly. + + Fix 970712-2.f: + * com.c (ffecom_sym_transform_): Preserve error_mark_node for type. + (ffecom_type_localvar_): Ditto. + (ffecom_sym_transform_): If type is error_mark_node, + don't error-check decl size, because back end responds by + setting that to an integer 0 instead of error_mark_node. + (ffecom_transform_common_): Same as earlier fix to _transform_ + in that size is checked by dividing BITS_PER_UNIT instead of + multiplying. + (ffecom_transform_equiv_): Ditto. + + Fix 970712-3.f: + * stb.c (ffestb_R10014_): Fix flaky fall-through in error + test for FFELEX_typeCONCAT by just replicating the code, + and do FFELEX_typeCOLONCOLON while at it. + +1997-07-07 Dave Love + + * intdoc.h: Add various missing pieces; correct GMTIME, LTIME + result ordering. + + * intrin.def, com-rt.def: Add alarm. + + * com.c (ffecom_expr_intrinsic_): Add case for alarm. + +Thu Jun 26 04:19:40 1997 Craig Burley + + Fix 970302-3.f: + * com.c (ffecom_sym_transform_): For sanity-check compare + of gbe size of local variable to g77 expectation, + use varasm.c/assemble_variable technique of dividing + BITS_PER_UNIT out of gbe info instead of multiplying + g77 info up, to avoid crash when size in bytes is very + large, and overflows an `int' or similar when multiplied. + + Fix 970626-2.f: + * com.c (ffecom_finish_symbol_transform_): Don't bother + transforming a dummy argument, to avoid a crash. + * ste.c (ffeste_R1227): Don't return a value if the + result decl, or its type, is error_mark_node. + + Fix 970626-4.f: + * lex.c (ffelex_splice_tokens): `-fdollar-ok' is + irrelevant to whether a DOLLAR token should be made + from an initial character of `$'. + + Fix 970626-6.f: + * stb.c (ffestb_do3_): DO iteration variable is an + lhs, not rhs, expression. + + Fix 970626-7.f and 970626-8.f: + * expr.c (ffeexpr_cb_comma_i_1_): Set IMPDO expression + to have clean info, because undefined rank, for example, + caused crash on mangled source on UltraSPARC but not + on Alpha for a series of weird reasons. + (ffeexpr_cb_close_paren_): If not CLOSE_PAREN, push + opANY expression onto stack instead of attempting + to mimic what program might have wanted. + (ffeexpr_cb_close_paren_): Don't wrap opPAREN around + opIMPDO, just warn that it's gratuitous. + * bad.def (FFEBAD_IMPDO_PAREN): New warning. + + Fix 970626-9.f: + * expr.c (ffeexpr_declare_parenthesized_): Must shut down + parsing in kindANY case, otherwise the parsing engine might + decide there's an ambiguity. + (ffeexpr_token_name_rhs_): Eliminate parentypeSUBROUTINE_ + case, so we crash right away if it comes through. + * st.c, st.h, sta.c, sta.h (ffest_shutdown, ffesta_shutdown): + New functions. + +Tue Jun 24 19:47:29 1997 Craig Burley + + * com.c (ffecom_check_size_overflow_): New function + catches some cases of the size of a type getting + too large. varasm.c must catch the rest. + (ffecom_sym_transform_): Use new function. + (ffecom_type_localvar_): Ditto. + +Mon Jun 23 01:09:28 1997 Craig Burley + + * global.c (ffeglobal_proc_def_arg): Fix comparison + of argno to #args. + (ffeglobal_proc_ref_arg): Ditto. + + * lang-options.h, top.c: Rename `-fdebug' to `-fxyzzy', + since it's an unsupported internals option and some + poor user might guess that it does something. + + * bad.def: Make a warning for each filewide diagnostic. + Put all filewides together. + * com.c (ffecom_sym_transform_): Don't substitute + known global tree for global entities when `-fno-globals'. + * global.c (ffeglobal_new_progunit_): Don't produce + fatal diagnostics about globals when `-fno-globals'. + Instead, produce equivalent warning when `-Wglobals'. + (ffeglobal_proc_ref_arg): Ditto. + (ffeglobal_proc_ref_nargs): Ditto. + (ffeglobal_ref_progunit_): Ditto. + * lang-options.h, top.c, top.h: New `-fno-globals' option. + +Sat Jun 21 12:32:54 1997 Craig Burley + + * expr.c (ffeexpr_fulfill_call_): Set array variable + to avoid warning about uninitialized variable. + + * Make-lang.in: Get rid of any setting of HOST_* macros, + since these will break gcc's build! + * makefile: New file to make building derived files + easier. + +Thu Jun 19 18:19:28 1997 Craig Burley + + * g77.c (main): Install Emilio Lopes' patch to support + Ratfor, and to fix the printing of the version string + to go to stderr, not stdout. + * lang-specs.h: Install Emilio Lopes' patch to support + Ratfor, and patch the result to support picking up + `*f771' from the `specs' file. + +Thu Jun 12 14:36:25 1997 Craig Burley + + * storag.c (ffestorag_update_init, ffestorag_update_save): + Also update parent, in case equivalence processing + has already eliminated pointers to it via the + local equivalence info. + +Tue Jun 10 14:08:26 1997 Craig Burley + + * intdoc.c: Add cross-reference to end of description + of any generic intrinsic pointing to other intrinsics + with the same name. + + Warn about explicit type declaration for intrinsic + that disagrees with invocation: + * expr.c (ffeexpr_paren_rhs_let_): Preserve type info + for intrinsic functions. + (ffeexpr_token_funsubstr_): Ditto. + * intrin.c (ffeintrin_fulfill_generic): Warn if type + info of fulfilled intrinsic invocation disagrees with + explicit type info given symbol. + (ffeintrin_fulfill_specific): Ditto. + * stc.c (ffestc_R1208_item): Preserve type info + for intrinsics. + (ffestc_R501_item): Ditto. + +Mon Jun 9 17:45:44 1997 Craig Burley + + * com.c (ffecom_expr_intrinsic_): Fix several of the + libU77/libF77-unix handlers to properly convert their + arguments. + + * com-rt.def (FFECOM_gfrtFSTAT): Append missing "i" to + arg string. + +Fri Jun 6 14:37:30 1997 Craig Burley + + * com.c (ffecom_expr_intrinsic_): Have a case statement + for every intrinsic implementation, so missing ones + are caught via gcc warnings. + Don't call ffeintrin_codegen_imp anymore. + * intrin.c (ffeintrin_fulfill_generic): Remove cg_imp + stuff from here. + (ffeintrin_codegen_imp): Delete this function. + * intrin.def, intrin.h: Remove DEFIMQ stuff from here + as well. + +Thu Jun 5 13:03:07 1997 Craig Burley + + * top.c (ffe_decode_option): New -fbadu77-intrinsics-* + options. + * top.h: Ditto. + * intrin.h: New BADU77 family. + * intrin.c (ffeintrin_state_family): Ditto. + + Implement new scheme to track intrinsic names vs. forms: + * intrin.c (ffeintrin_fulfill_generic), + (ffeintrin_fulfill_specific), (ffeintrin_is_intrinsic), + intrin.def: The documented name is now either in the + generic info or, if no generic, in the specific info. + For a generic, the specific info contains merely the + distinguishing form (usually "function" or "subroutine"), + used for diagnostics about ambiguous references and + in the documentation. + + * intrin.def: Clean up formatting of DEFNAME block. + Convert many libU77 intrinsics into generics that + support both subroutine and function forms. + Put the function forms of side-effect routines into + the new BADU77 family. + Make MCLOCK and TIME return INTEGER*4 again, and add + INTEGER*8 equivalents called MCLOCK8 and TIME8. + Fix up more status return values to be written and + insist on them being I1 as well. + * com.c (ffecom_expr_intrinsic_): Lots of changes to + support new libU77 intrinsic interfaces. + +Mon Jun 2 00:37:53 1997 Craig Burley + + * com.c (ffecom_init_0): Pointer type is now INTEGER(KIND=7), + not INTEGER(KIND=0), since we want to reserve KIND=0 for + future use. + +Thu May 29 14:30:33 1997 Craig Burley + + Fix bugs preventing CTIME(I*4) from working correctly: + * com.c (ffecom_char_args_): For FUNCREF case, process + args to intrinsic just as they would be in + ffecom_expr_intrinsic_. + * com-rt.def (FFECOM_gfrtCTIME, FFECOM_gfrtTTYNAM): Fix + argument decls to specify `&'. + +Wed May 28 22:19:49 1997 Craig Burley + + Fix gratuitous warnings exposed by dophot aka 970528-1: + * global.c (ffeglobal_proc_def_arg, ffeglobal_proc_ref_arg): + Support distinct function/subroutine arguments instead of + just procedures. + * global.h: Ditto. + * expr.c (ffeexpr_fulfill_call_): A SYMTER with kindNONE + also is a procedure (either function or subroutine). + +Mon May 26 20:25:31 1997 Craig Burley + + * bad.def: Have several lexer diagnostics refer to + documentation for people who need more info on what Fortran + source code is supposed to look like. + + * expr.c (ffeexpr_reduced_bool1_), bad.def: New diagnostics + specific to .NOT. now mention only one operand instead + of two. + + * g77.c: Recognize -fsyntax-only, similar to -c etc. + (lookup_option): Fix bug that prevented non-`--' options + from being recognized. + +Sun May 25 04:29:04 1997 Craig Burley + + * intrin.def (FFEINTRIN_impCTIME): Accept `I*' expression + for STime instead of requiring `I2'. + +Tue May 20 16:14:40 1997 Craig Burley + + * symbol.c (ffesymbol_reference): All references to + standard intrinsics are considered explicit, so as + to avoid generating basically useless warnings. + * intrin.c, intrin.h (ffeintrin_is_standard): Returns TRUE + if intrinsic is standard. + +Sun May 18 21:14:59 1997 Craig Burley + + * com-rt.def: Changed all external names of the + form `"\([a-z0-9]*\)_' to `"G77_\1_0"' so as to + allow any name valid as an intrinsic to be used + as such and as a user-defined external procedure + name or common block as well. + +Thu May 8 13:07:10 1997 Craig Burley + + * expr.c (ffeexpr_cb_end_notloc_): For %VAL, %REF, and + %DESCR, copy arg info into new node. + +Mon May 5 14:42:17 1997 Craig Burley + + From Uwe F. Mayer : + * Make-lang.in (g77-cross): Fix typo in g77.c path. + + From Brian McIlwrath : + * lang-specs.h: Have g77 pick up options from a section + labeled `*f771' of the `specs' file. + +Sat May 3 02:46:08 1997 Craig Burley + + * intrin.def (FFEINTRIN_defSIGNAL): Add optional `Status' + argument that com.c already expects (per Dave Love). + + More changes to support better tracking of (filewide) + globals, in particular, the arguments to procedures: + * bad.def (FFEBAD_FILEWIDE_NARGS, FFEBAD_FILEWIDE_NARGS_W, + FFEBAD_FILEWIDE_ARG, FFEBAD_FILEWIDE_ARG_W): New diagnostics. + * expr.c (ffebad_fulfill_call_): Provide info on each + argument to ffeglobal. + * global.c, global.h (ffeglobal_proc_def_arg, + ffeglobal_proc_def_nargs, ffeglobal_proc_ref_arg, + ffeglobal_proc_ref_args): New functions. + (ffeglobalArgSummary, ffeglobalArgInfo_): New types. + +Tue Apr 29 18:35:41 1997 Craig Burley + + More changes to support better tracking of (filewide) + globals: + * expr.c (ffeexpr_fulfill_call_): New function. + (ffeexpr_token_name_lhs_): Call after building procedure + reference expression. Also leave info field for ANY-ized + expression alone. + (ffeexpr_token_arguments_): Ditto. + +Mon Apr 28 20:04:18 1997 Craig Burley + + Changes to support better tracking of (filewide) + globals, mainly to avoid crashes due to inlining: + * bad.def: Go back to quoting intrinsic names, + (FFEBAD_FILEWIDE_DISAGREEMENT, FFEBAD_FILEWIDE_TIFF, + FFEBAD_FILEWIDE_TYPE_MISMATCH): New diagnostics. + (FFEBAD_INTRINSIC_EXPIMP, FFEBAD_INTRINSIC_GLOBAL): Reword + for clarity. + * com.c (ffecom_do_entry_, ffecom_start_progunit_, + ffecom_sym_transform_): Accommodate new FFEGLOBAL_typeEXT + possibility. + * expr.c (ffeexpr_sym_lhs_call_, ffeexpr_sym_lhs_extfunc_, + ffeexpr_sym_rhs_actualarg_, ffeexpr_declare_parenthesized_, + ffeexpr_paren_rhs_let_, ffeexpr_token_funsubstr_): + Fill in real kind info instead of leaving NONE where + appropriate. + Register references to intrinsics and globals with ffesymbol + using new ffesymbol_reference function instead of + ffesymbol_globalize. + * global.c (ffeglobal_type_string_): New array for + new diagnostics. + * global.h, global.c: + Replace ->init mechanism with ->tick mechanism. + Move other common-related members into a substructure of + a union, so the proc substructure can be introduced + to include members related to externals other than commons. + Don't complain about ANY-ized globals; ANY-ize globals + once they're complained about, in any case where code + generation could become a problem. + Handle global entries that have NONE type (seen as + intrinsics), EXT type (seen as EXTERNAL), and so on. + Keep track of kind and type of externals, both via + definition and via reference. + Diagnose disagreements about kind or type of externals + (such as functions). + (ffeglobal_ref_intrinsic, ffeglobal_ref_progunit_): New + functions. + * stc.c (ffestc_R1207_item, ffestc_R1208_item, + ffestc_R1219, ffestc_R1226): + Call ffesymbol_reference, not ffesymbol_globalize. + * stu.c (ffestu_sym_end_transition, + ffestu_sym_exec_transition): + Call ffesymbol_reference, not ffesymbol_globalize. + * symbol.c (ffesymbol_globalize): Removed... + (ffesymbol_reference): ...to this new function, + which more generally registers references to symbols, + globalizes globals, and calls on the ffeglobal module + to check globals filewide. + + * global.h, global.c: Rename some macros and functions + to more clearly distinguish common from other globals. + All callers changed. + + * com.c (ffecom_sym_transform_): Trees describing + filewide globals must be allocated on permanent obstack. + + * expr.c (ffeexpr_token_name_lhs_): Don't generate + gratuitous diagnostics for FFEINFO_whereANY case. + +Thu Apr 17 03:27:18 1997 Craig Burley + + * global.c: Add support for flagging intrinsic/global + confusion via warnings. + * bad.def (FFEBAD_INTRINSIC_EXPIMP, + FFEBAD_INTRINSIC_GLOBAL): New diagnostics. + * expr.c (ffeexpr_token_funsubstr_): Ditto. + (ffeexpr_sym_lhs_call_): Ditto. + (ffeexpr_paren_rhs_let_): Ditto. + * stc.c (ffestc_R1208_item): Ditto. + +Wed Apr 16 22:40:56 1997 Craig Burley + + * expr.c (ffeexpr_declare_parenthesized_): INCLUDE + context can't be an intrinsic invocation either. + +Fri Mar 28 10:43:28 1997 Craig Burley + + * expr.c (ffeexpr_token_arguments_): Make sure top of + exprstack is operand before dereferencing operand field. + + * lex.c (ffelex_prepare_eos_): Fill up truncated + hollerith token, so crash on null ->text field doesn't + happen later. + + * stb.c (ffestb_R10014_): If NAMES isn't recognized (or + the recognized part is followed in the token by a + non-digit), don't try and collect digits, as there + might be more than FFEWHERE_indexMAX letters to skip + past to do so -- and the code is diagnosed anyway. + +Thu Mar 27 00:02:48 1997 Craig Burley + + * com.c (ffecom_sym_transform_): Force local + adjustable array onto stack. + + * stc.c (ffestc_R547_item_object): Don't actually put + the symbol in COMMON if the symbol has already been + EQUIVALENCE'd to a different COMMON area. + + * equiv.c (ffeequiv_add): Don't actually do anything + if there's a disagreement over which COMMON area is + involved. + +Tue Mar 25 03:35:19 1997 Craig Burley + + * com.c (ffecom_transform_common_): If no explicit init + of COMMON area, don't actually init it even though + storage area suggests it. + +Mon Mar 24 12:10:08 1997 Craig Burley + + * lex.c (ffelex_image_char_): Avoid overflowing the + column counter itself, as well as the card image. + + * where.c (ffewhere_line_new): Cast ffelex_line_length() + to (size_t) so 255 doesn't overflow to 0! + + * stc.c (ffestc_labeldef_notloop_begin_): Don't gratuitously + terminate loop before processing statement, so block + doesn't disappear out from under EXIT/CYCLE processing. + (ffestc_labeldef_notloop_): Has old code from above + function, instead of just calling it. + + * expr.c (ffeexpr_cb_comma_i_4_): Don't skip over + arbitrary token (such as EOS). + + * com.c (ffecom_init_zero_): Handle RECORD_TYPE and + UNION_TYPE so -fno-zeros works with -femulated-complex. + +1997-03-12 Dave Love + + * intrin.def: New intrinsics INT2, INT8, CPU_TIME. Fix AND, OR, + XOR. [Integrated by burley, AND/OR/XOR already fixed, INT8 + implementation changed/fixed.] + +Wed Mar 12 10:40:08 1997 Craig Burley + + * Make-lang.in ($(srcdir)/f/intdoc.texi): Simplify rules + so building f/intdoc is not always necessary; remove + f/intdoc after running it if it is built. + +Tue Mar 11 23:42:00 1997 Craig Burley + + * intrin.def (FFEINTRIN_impAND, FFEINTRIN_impOR, + FFEINTRIN_impXOR): Use the IAND, IOR, and IEOR implementations + of these, instead of crashing in ffecom_expr_intrinsic_ + or adding case labels there. + +Mon Mar 10 22:51:23 1997 Craig Burley + + * intdoc.c: Fix so any C compiler can compile this. + +Fri Feb 28 13:16:50 1997 Craig Burley + + * Version 0.5.20 released. + +Fri Feb 28 01:45:25 1997 Craig Burley + + * Make-lang.in (RUNTIMESTAGESTUFF, LIBU77STAGESTUFF): + Move some files incorrectly in the former to the latter, + and add another file or two to the latter. + + New meanings for (KIND=n), and new denotations in the + little language describing intrinsics: + * com.c (ffecom_init_0): Assign new meanings. + * intdoc.c: Document new meanings. + Support the new denotations. + * intrin.c: Employ new meanings, mapping them to internal + values (which are the same as they ever were for now). + Support the new denotations. + * intrin.def: Switch DEFIMP table to the new denotations. + + * intrin.c (ffeintrin_check_): Fix bug that was leaving + LOC() and %LOC() returning INTEGER*4 on systems where + it should return INTEGER*8. + + * type.c: Canonicalize function definitions, for etags + and such. + +Wed Feb 26 20:43:03 1997 Craig Burley + + * com.c (ffecom_init_0): Choose INTEGER(KIND=n) types, + where n is 2, 3, and 4, according to the new docs + instead of according to the old C correspondences + (which seem less useful at this point). + + * equiv.c (ffeequiv_destroy_): New function. + (ffeequiv_layout_local_): Use this new function + whenever the laying out of a local equivalence chain + is aborted for any reason. + Otherwise ensure that symbols no longer reference + the stale ffeequiv entries that result when they + are killed off in this procedure. + Also, the rooted symbol is one that has storage, + it really is irrelevant whether it has an equiv entry + at this point (though the code to remove the equiv + entry was put in at the end, just in case). + (ffeequiv_kill): When doing internal checks, make + sure the victim isn't named by any symbols it points + to. Not as complete a check as looking through the + entire symbol table (which does matter, since some + code in equiv.c used to remove symbols from the lists + for an ffeequiv victim but not remove that victim as the + symbol's equiv info), but this check did find some + real bugs in the code (that were fixed). + +Mon Feb 24 16:42:13 1997 Craig Burley + + * com.c (ffecom_expr_intrinsic_): Fix a couple of + warnings about uninitialized variables. + * intrin.c (ffeintrin_check_): Ditto, but there were + a couple of _real_ uninitialized-variable _bugs_ here! + (ffeintrin_fulfill_specific): Ditto, no real bug here. + +Sun Feb 23 15:01:20 1997 Craig Burley + + Clean up diagnostics (especially about intrinsics): + * bad.def (FFEBAD_UNIMPL_STMT): Remove. + (FFEBAD_INTRINSIC_*, FFEBAD_NEED_INTRINSIC): Clean these + up so they're friendlier. + (FFEBAD_INTRINSIC_CMPAMBIG): New. + * intrin.c (ffeintrin_fulfill_generic, + ffeintrin_fulfill_specific, ffeintrin_is_intrinsic): + Always choose + generic or specific name text (which is for doc purposes + anyway) over implementation name text (which is for + internal use). + * intrin.def: Use more descriptive name texts for generics + and specifics in cases where the names themselves are not + enough (e.g. IDATE, which has two forms). + + Fix some intrinsic mappings: + * intrin.def (FFEINTRIN_specIDINT, FFEINTRIN_specAND, + FFEINTRIN_specDFLOAT, FFEINTRIN_specDREAL, FFEINTRIN_specOR, + FFEINTRIN_specXOR): Now have their own implementations, + instead of borrowing from others. + (FFEINTRIN_specAJMAX0, FFEINTRIN_specAJMIN0, FFEINTRIN_specBJTEST, + FFEINTRIN_specDFLOTJ, FFEINTRIN_specFLOATJ, FFEINTRIN_specJIABS, + FFEINTRIN_specJIAND, FFEINTRIN_specJIBCLR, FFEINTRIN_specJIBITS, + FFEINTRIN_specJIBSET, FFEINTRIN_specJIDIM, FFEINTRIN_specJIDINT, + FFEINTRIN_specJIDNNT, FFEINTRIN_specJIEOR, FFEINTRIN_specJIFIX, + FFEINTRIN_specJINT, FFEINTRIN_specJIOR, FFEINTRIN_specJISHFT, + FFEINTRIN_specJISHFTC, FFEINTRIN_specJISIN, FFEINTRIN_specJMAX0, + FFEINTRIN_specJMAX1, FFEINTRIN_specJMIN0, FFEINTRIN_specJMIN1, + FFEINTRIN_specJMOD, FFEINTRIN_specJNINT, FFEINTRIN_specJNOT,): + Turn these implementations off, since it's not clear + just what types they expect in the context of portable Fortran. + (DFLOAT): Now in FVZ family, since f2c supports them + + Support intrinsic inquiry functions (BIT_SIZE, LEN): + * intrin.c: Allow `i' in . + * intrin.def (FFEINTRIN_impBIT_SIZE, FFEINTRIN_impLEN): + Mark args with `i'. + +Sat Feb 22 13:34:09 1997 Craig Burley + + Only warn, don't error, for reference to unimplemented + intrinsic: + * bad.def (FFEBAD_INTRINSIC_UNIMPLW): Warning version + of _UNIMPL. + * intrin.c (ffeintrin_is_intrinsic): Use new warning + version of _UNIMPL (FFEBAD_INTRINSIC_UNIMPLW). + + Complain about REAL(Z) and AIMAG(Z) (Z is DOUBLE COMPLEX): + * bad.def (FFEBAD_INTRINSIC_CMPAMBIG): New diagnostic. + * expr.c: Needed #include "intrin.h" anyway. + (ffeexpr_token_intrincheck_): New function handles delayed + diagnostic for "REAL(REAL(expr)" if next token isn't ")". + (ffeexpr_token_arguments_): Do most of the actual checking here. + * intrin.h, intrin.c (ffeintrin_fulfill_specific): New + argument, check_intrin, to tell caller that intrin is REAL(Z) + or AIMAG(Z). All callers updated, mostly to pass NULL in + for this. + (ffeintrin_check_): Also has new arg check_intrin for same + purpose. All callers updated the same way. + * intrin.def (FFEINTRIN_impAIMAG): Change return type + from "R0" to "RC", to accommodate f2c (and perhaps other + non-F90 F77 compilers). + * top.h, top.c: New option -fugly-complex. + + New GNU intrinsics REALPART, IMAGPART, and COMPLEX: + * com.c (ffecom_expr_intrinsic_): Implement impCOMPLEX + and impREALPART here. (specIMAGPART => specAIMAG.) + * intrin.def: Add the intrinsics here. + + Rename implementations of VXTIDATE and VXTTIME to IDATEVXT + and TIMEVXT, so they sort more consistently: + * com.c (ffecom_expr_intrinsic_): + * intrin.def: + + Delete intrinsic group `dcp', add `gnu', etc.: + * intrin.c (ffeintrin_state_family): FFEINTRIN_familyGNU + replaces FFEINTRIN_familyDCP, and gets state from `gnu' + group. + Get rid of FFEINTRIN_familyF2Z, nobody needs it. + Move FFEINTRIN_specDCMPLX from DCP family to FVZ family, + as f2c has it. + Move FFEINTRIN_specDFLOAT from F2C family to FVZ family. + (FFEINTRIN_specZABS, FFEINTRIN_specZCOS, FFEINTRIN_specZEXP, + FFEINTRIN_specZLOG, FFEINTRIN_specZSIN, FFEINTRIN_specZSQRT): + Move these from F2Z family to F2C family. + * intrin.h (FFEINTRIN_familyF2Z, FFEINTRIN_familyDCP): Remove. + (FFEINTRIN_familyGNU): Add. + * top.h, top.c: Replace `dcp' with `gnu'. + + * com.c (ffecom_expr_intrinsic_): Clean up by collecting + simple conversions into one nice, conceptual place. + Fix up some intrinsic subroutines (MVBITS, KILL, UMASK) to + properly push and pop call temps, to avoid wasting temp + registers. + + * g77.c (doit): Toon says variables should be defined + before being referenced. Spoilsport. + + * intrin.c (ffeintrin_check_): Now Dave's worried about + warnings about uninitialized variables. Okay, so for + basic return values 'g' and 's', they _were_ + uninitialized -- is determinism really _that_ useful? + + * intrin.def (FFEINTRIN_impFGETC): Fix STATUS argument + so that it is INTENT(OUT) instead of INTENT(IN). + +1997-02-21 Dave Love + + * intrin.def, com.c: Support Sun-type `short' and `long' + intrinsics. Perhaps should also do Microcruft-style `int2'. + +Thu Feb 20 15:16:53 1997 Craig Burley + + * com.c (ffecom_expr_intrinsic_): Clean up indentation. + Support SECONDSUBR intrinsic implementation. + Rename SECOND to SECONDFUNC for direct support via library. + + * g77.c: Fix to return proper status value to shell, + by obtaining it from processes it spawns. + + * intdoc.c: Fix minor typo. + + * intrin.def: Turn SECOND into generic that maps into + function and subroutine forms. + + * intrin.def: Make FLOAT and SNGL into specific intrinsics. + + * intrin.def, intrin.h: Change the way DEFGEN and DEFSPEC + macros work, to save on verbage. + +Mon Feb 17 02:08:04 1997 Craig Burley + + New subsystem to automatically generate documentation + on intrinsics: + * Make-lang.in ($(srcdir)/f/g77.info, + $(srcdir)/f/g77.dvi): Move g77 doc rules around. + Add to g77 doc rules the new subsystem. + (f77.mostlyclean, f77.maintainer-clean): Also clean up + after new doc subsystem. + * intdoc.c, intdoc.h: New doc subsystem code. + * intrin.h [FFEINTRIN_DOC]: When 1, don't pull in + stuff not needed by doc subsystem. + + Improve on intrinsics mechanism to both be more + self-documenting and to catch more user errors: + * intrin.c (ffeintrin_check_): Recognize new arg-len + and arg-rank information, and check it. + Move goto and signal indicators to the basic type. + Permit reference to arbitrary argument number, not + just first argument (for BESJN and BESYN). + (ffeintrin_init_0): Check and accept new notations. + * intrin.c, intrin.def: Value in COL now identifies + arguments starting with number 0 being the first. + + Some minor intrinsics cleanups (resulting from doc work): + * com.c (ffecom_expr_intrinsic_): Implement FLUSH + directly once again, handle its optional argument, + so it need not be a generic (awkward to handle in docs). + * intrin.def (BESJ0, BESJ1, BESJN, BESY0, BESY1, BESYN, + CHDIR, CHMOD, CTIME, DBESJ0, DBESJ1, DBESJN, DBESY0, + DBESY1, DBESYN, DDIM, ETIME, FGETC, FNUM, FPUTC, FSTAT, + GERROR, GETCWD, GETGID, GETLOG, GETPID, GETUID, GMTIME, + HOSTNM, IDATE, IERRNO, IIDINT, IRAND, ISATTY, ITIME, JIDINT, + LNBLNK, LSTAT, LTIME, MCLOCK, PERROR, SRAND, SYMLNK, TTYNAM, + UMASK): Change capitalization of initcaps (official) name + to be consistent with Burley's somewhat arbitrary rules. + (BESJN, BESYN): These have return arguments of same type + as their _second_ argument. + (FLUSH): Now a specific, not generic, intrinsic, with one + optional argument. + (FLUSH1): Eliminated. + Add arg-len and arg-rank info to several intrinsics. + (ITIME): Change argument type from REAL to INTEGER. + +Tue Feb 11 14:04:42 1997 Craig Burley + + * Make-lang.in (f771): Invocation of Makefile now done + with $(srcdir)=gcc to go along with $(VPATH)=gcc. + ($(srcdir)/f/runtime/configure, + $(srcdir)/f/runtime/libU77/configure): Break these out + so spurious triggers of this rule don't happen (as when + configure.in is more recent than libU77/configure). + (f77.rebuilt): Distinguish source versus build files, + so this target can be invoked from build directory and + still work. + * Makefile.in: This now expects $(srcdir) to be the gcc + source directory, not gcc/f, to agree with $(VPATH). + Accordingly, $(INCLUDES) has been fixed, various cruft + removed, the removal of f771 has been fixed to remove + the _real_ f771 (not the one in gcc's parent directory), + and so on. + + * lex.c: Part of ffelex_finish_statement_() now done + by new function ffelex_prepare_eos_(), so that, in one + popular case, the EOS can be prepared while the pointer + is at the end of the non-continued line instead of the + end of the line that marks no continuation. This improves + the appearance of diagnostics substantially. + +Mon Feb 10 12:44:06 1997 Craig Burley + + * Make-lang.in: runtime Makefile's, and include/f2c.h, + also depend on f/runtime/configure and f/runtime/libU77/configure. + + Fix various libU77 routines: + * com-rt.def (FFECOM_gfrtCTIME, FFECOM_gfrtMCLOCK, + FFECOM_gfrtTIME): These now use INTEGER*8 for time values, + for compatibility with systems like Alpha. + (FFECOM_gfrtSYSTEM_CLOCK, FFECOM_gfrtTTYNAM): Delete incorrect + trailing underscore in routine names. + * intrin.c, intrin.def: Support INTEGER*8 return values and + arguments ('4'). Change FFEINTRIN_impCTIME, FFEINTRIN_impMCLOCK, + and FFEINTRIN_impTIME accordingly. + (ffeintrin_is_intrinsic): Don't give caller a clue about + form of intrinsic -- shouldn't be needed at this point. + + Cope with generic intrinsics that are subroutines and functions: + * com.c (ffecom_finish_symbol_transform_, ffecom_expr_transform_): + Don't transform an intrinsic that is not known to be a subroutine + or a function. (Maybe someday have to avoid transforming + any intrinsic with an undecided or unknown implementation.) + * expr.c (ffeexpr_declare_unadorned_, + ffeexpr_declare_parenthesized_): Ok to invoke generic + intrinsic that has at least one subroutine form as a + subroutine. + Ok to pass intrinsic as actual arg if it has a known specific + intrinsic form that is valid as actual arg. + (ffeexpr_declare_parenthesized_): An unknown kind of + intrinsic has a paren_type chosen based on context. + (ffeexpr_token_arguments_): Build funcref/subrref based + on context, not on kind of procedure being called. + * intrin.h, intrin.c (ffeintrin_is_intrinsic): Undo changes of + Tue Feb 4 23:12:04 1997 by me, change all callers to leave + intrinsics as FFEINFO_kindNONE at this point. (Some callers + also had unused variables deleted as a result.) + + Enable all intrinsic groups (especially f90 and vxt): + * target.h (FFETARGET_defaultSTATE_DCP, FFETARGET_defaultSTATE_F2C, + FFETARGET_defaultSTATE_F90, FFETARGET_defaultSTATE_MIL, + FFETARGET_defaultSTATE_UNIX, FFETARGET_defaultSTATE_VXT): + Delete these macros, let top.c set them directly. + * top.c (ffeintrinsic_state_dcp_, ffe_intrinsic_state_f2c_, + ffe_intrinsic_state_f90_, ffe_intrinsic_state_mil_, + ffe_intrinsic_state_unix_, ffe_intrinsic_state_vxt_): + Enable all these directly. + +Sat Feb 8 03:21:50 1997 Craig Burley + + * g77.c: Incorporate recent changes to ../gcc.c. + For version magic (e.g. `g77 -v'), instead of compiling + /dev/null, write, compile, run, and then delete a small + program that prints the version numbers of the three + components of libf2c (libF77, libI77, and libU77), + so we get this info with bug reports. + Also, this change reduces the chances of accidentally + linking to an old (complex-alias-problem) libf2c. + Fix `-L' so the argument is expected in `-Larg'. + + * com.h (FFECOM_f2cLONGINT): For INTEGER*8 support in f2c.h, + dynamically determine proper type here, instead of + assuming `long long int' is correct. + +Tue Feb 4 23:12:04 1997 Craig Burley + + Add libU77 library from Dave Love : + * Make-lang.in (f77-runtime): Depend on new Makefile. + (f/runtime/libU77/Makefile): New rule. + Also configure libU77. + ($(srcdir)/f/runtime/configure: Use Makefile.in, + so configuration doesn't have to have happened. + (f77.mostlyclean, f77.clean, f77.distclean, + f77.maintainer-clean): Some fixups here, but more work + needed. + (RUNTIMESTAGESTUFF): Add libU77's config.status. + (LIBU77STAGESTUFF, f77.stage1, f77.stage2, f77.stage3, + f77.stage4): New macro, appropriate uses added. + * com-rt.def: Add libU77 procedures. + * com.c (ffecom_f2c_ptr_to_integer_type_node, + ffecom_f2c_ptr_to_real_type_node): New type nodes. + (FFECOM_rttypeCHARACTER_): New type of run-time function. + (ffecom_char_args_): Handle CHARACTER*n intrinsics + where n != 1 here, instead of in ffecom_expr_intrinsic_. + (ffecom_expr_intrinsic_): New code to handle new + intrinsics. + In particular, change how FFEINTRIN_impFLUSH is handled. + (ffecom_make_gfrt_): Handle new type of run-time function. + (ffecom_init_0): Initialize new type nodes. + * config-lang.in: New libU77 directory. + * intrin.h, intrin.c (ffeintrin_is_intrinsic): Handle + potential generic for subroutine _and_ function + specifics via two new arguments. All callers changed. + Properly ignore deleted/disabled intrinsics in resolving + generics. + (ffeintrin_check_, ffeintrin_init_0): Handle CHARACTER intrinsics of (*) + length. + * intrin.def: Permission granted by FSF to place this in + public domain, which will allow it to serve as source + for both g77 program and its documentation. + Add libU77 intrinsics. + (FLUSH): Now a generic, not specific, intrinsic. + (DEFIMP): Now support return modifier for CHARACTER intrinsics. + + * com-rt.def (FFECOM_gfrtDIM, FFECOM_gfrtERF, + FFECOM_gfrtERFC, FFECOM_gfrtEXP, FFECOM_gfrtSIGN, + FFECOM_gfrtSIN, FFECOM_gfrtSINH, FFECOM_gfrtTAN, + FFECOM_gfrtTANH, FFECOM_gfrtPOW_RI): Change "&r" to "&f". + +Sat Feb 1 12:15:09 1997 Craig Burley + + * Version 0.5.19.1 released. + + * com.c (ffecom_expr_, ffecom_expr_intrinsic_, + ffecom_tree_divide_): FFECOM_gfrtPOW_ZI, + FFECOM_gfrtCONJG, FFECOM_gfrtDCONJG, + FFECOM_gfrtCCOS, FFECOM_gfrtCDCOS, + FFECOM_gfrtCLOG, FFECOM_gfrtCDLOG, + FFECOM_gfrtCSIN, FFECOM_gfrtCDSIN, + FFECOM_gfrtCSQRT, FFECOM_gfrtCDSQRT, + FFECOM_gfrtDIV_CC, FFECOM_gfrtDIV_ZZ: These all require + result to _not_ overlap one or more inputs. + +Sat Feb 1 00:25:55 1997 Craig Burley + + * com.c (ffecom_init_0): Do internal checks only if + -fset-g77-defaults not specified. + + Fix %LOC(), LOC() to return sufficiently wide type: + * com.h, com.c (ffecom_pointer_kind_, ffecom_label_kind_, + ffecom_pointer_kind(), ffecom_label_kind()): New globals + and accessor macros hold kind for integer pointers on target + machine. + (ffecom_init_0): Determine narrowest INTEGER type that + can hold a pointer (usually INTEGER*4 or INTEGER*8), + store it in ffecom_pointer_kind_, etc. + * expr.c (ffeexpr_cb_end_loc_): Use right type for %LOC(). + * intrin.c (ffeintrin_check_, ffeintrin_init_0): Support + new 'p' kind for type of intrinsic. + * intrin.def (FFEINTRIN_impLOC): Returns "Ip" instead of "I1", + so LOC() type is correct for target machine. + + Support -fugly-assign: + * lang-options.h, top.h, top.c (ffe_decode_option): + Accept -fugly-assign and -fno-ugly-assign. + * com.c (ffecom_expr_): Handle -fugly-assign. + * expr.c (ffeexpr_finished_): Check right type for ASSIGN + contexts. + +Fri Jan 31 14:30:00 1997 Craig Burley + + Remove last vestiges of -fvxt-not-f90: + * stb.c (ffestb_R10012_, ffestb_R10014_, ffestb_V0201_): + top.c, top.h: + +Fri Jan 31 02:13:54 1997 Craig Burley + + * top.c (ffe_decode_option): Warn if -fugly is specified, + it'll go away soon. + + * symbol.h: No need to #include "bad.h". + + Reorganize features from -fvxt-not-f90 to -fvxt: + * lang-options.h, top.h, top.c: + Accept -fvxt and -fno-vxt, but not -fvxt-not-f90 or -ff90-not-vxt. + Warn if the latter two are used. + * expr.c (ffeexpr_nil_rhs_): Double-quote means octal constant. + (ffeexpr_token_rhs_): Double-quote means octal constant. + * target.h (FFETARGET_defaultIS_VXT_NOT_90): Delete macro + definition, no longer needed. + + Make some -ff90 features the default: + * data.c (ffedata_value): DATA implies SAVE. + * src.h (ffesrc_is_name_noninit): Underscores always okay. + + Fix up some more #error directives by quoting their text: + * bld.c (ffebld_constant_is_zero): + * target.h: + +Sat Jan 18 18:22:09 1997 Craig Burley + + * g77.c (lookup_option, main): Recognize `-Xlinker', + `-Wl,', `-l', `-L', `--library-directory', `-o', + `--output'. + (lookup_option): Don't depend on SWITCH_TAKES_ARG + being correct, it might or might not have `-x' in + it depending on host. + Return NULL argument if it would be an empty string. + (main): If no input files (by gcc.c's definition) + but `-o' or `--output' specified, produce diagnostic + to avoid overwriting output via gcc. + Recognize C++ `+e' options. + Treat -L as another non-magical option (like -B). + Don't append_arg `-x' twice. + +Fri Jan 10 23:36:00 1997 Craig Burley + + * top.c [BUILT_FOR_270] (ffe_decode_option): Make + -fargument-noalias-global the default. + +Fri Jan 10 07:42:27 1997 Craig Burley + + Enable inlining of previously-compiled program units: + * com.c (ffecom_do_entry_, ffecom_start_progunit_): + Register new public function in ffeglobal database. + (ffecom_sym_transform_): Any GLOBAL or potentially GLOBAL + symbol should be looked up in ffeglobal database and + that tree node used, if found. That way, gcc knows + the references are to those earlier definitions, so it + can emit shorter branches/calls, inline, etc. + (ffecom_transform_common_): Minor change for clarity. + * expr.c (ffeexpr_sym-lhs_call_, ffeexpr_sym_lhs_extfunc_, + ffeexpr_sym_rhs_actualarg_, ffeexpr_paren_rhs_let_, + ffeexpr_token_funsubstr_): Globalize symbol as needed. + * global.c (ffeglobal_promoted): New function to look up + existing local symbol in ffeglobal database. + * global.h: Declare new function. + * name.h (ffename_token): New macro, plus alphabetize. + * stc.c (ffestc_R1207_item): Globalize EXTERNAL symbol. + * stu.c (ffestu_sym_end_transition, ffestu_sym_exec_transition): + Globalize symbol as needed. + * symbol.h, symbol.c (ffesymbol_globalize): New function. + +Thu Jan 9 14:20:00 1997 Craig Burley + + * ste.c (ffeste_R809): Produce a diagnostic for SELECT CASE + on CHARACTER type, instead of crashing. + +Thu Jan 9 00:52:45 1997 Craig Burley + + * stc.c (ffestc_order_entry_, ffestc_order_format_, + ffestc_R1226): Allow ENTRY and FORMAT before IMPLICIT + NONE, by having them transition only to state 1 instead + of state 2 (which is disallowed by IMPLICIT NONE). + +Mon Jan 6 22:44:53 1997 Craig Burley + + Fix AXP bug found by Rick Niles (961201-1.f): + * com.c (ffecom_init_0): Undo my 1996-05-14 change, as + it is incorrect and prevented easily finding this bug. + * target.h [__alpha__] (ffetargetReal1, ffetargetReal2): + Use int instead of long. + (ffetarget_cvt_r1_to_rv_, ffetarget_cvt_rv_to_r1_, + ffetarget_cvt_r2_to_rv_, ffetarget_cvt_rv_to_r2_): + New functions that intercede for callers of + REAL_VALUE_(TO|UNTO)_TARGET_(SINGLE|DOUBLE). + All callers changed, and damaging casts to (long *) removed. + +Sun Jan 5 03:26:11 1997 Craig Burley + + * Make-lang.in (g77, g77-cross): Depend on both g77.c and + zzz.c, in $(srcdir)/f/. + + Better design for -fugly-assumed: + * stc.c (ffestc_R501_item, ffestc_R524_item, + ffestc_R547_item_object): Pass new is_ugly_assumed flag. + * stt.c, stt.h (ffestt_dimlist_as_expr, + ffestt_dimlist_type): New is_ugly_assumed flag now + controls whether "1" is treated as "*". + Don't treat "2-1" or other collapsed constants as "*". + +Sat Jan 4 15:26:22 1997 Craig Burley + + * stb.c (ffestb_R10012_): Don't confirm on FORMAT(A,) + or even FORMAT(A,,B), as R1229 only warns about the + former currently, and this seems reasonable. + + Improvements to diagnostics: + * sta.c (ffesta_second_): Don't add any ffestb parsers + unless they're specifically called for. + Set up ffesta_tokens[0] before calling ffestc_exec_transition, + else stale info might get used. + (ffesta_save_): Do a better job picking which parser to run + after running all parsers with no confirmed possibles. + (FFESTA_maxPOSSIBLES_): Decrease from 100 now that so few + possibles are ever on the list at a given time. + (struct _ffesta_possible): Add named attribute. + (ffesta_add_possible_exec_, ffesta_add_possible_nonexec_): + Make these into macros that call a single function that now + sets the named attribute. + (ffesta_add_possible_unnamed_exec_, + ffeseta_add_possible_unnamed_nonexec_): New macros. + (ffesta_second_): Designate unnamed possibles as + appropriate. + * stb.c (ffestb_R1229, ffestb_R12291_): Use more general + diagnostic, so things like "POINTER (FOO, BAR)" are + diagnosed as unrecognized statements, not invalid statement + functions. + * stb.h, stb.c (ffestb_unimplemented): Remove function. + +1996-12-30 Dave Love + + * com.c: #include libU77/config.h + (ffecom_f2c_ptr_to_integer_type_node, + ffecom_f2c_ptr_to_integer_type_node): New variables. + (ffecom_init_0): Use them. + (ffecom_expr_intrinsic_): Many news cases for libU77 intrinsics. + + * com-rt.def: New definitions for libU77. + * intrin.def: Likewise. Also correct ftell arg spec. + + * Makefile.in (f/runtime/libU77/config.h): New target for com.c + dependency. + * Make-lang.in (f771): Depend on f/runtime/Makefile for the above. + +Sat Dec 28 12:28:29 1996 Craig Burley + + * stt.c (ffestt_dimlist_type): Treat ([...,]1) in dimlist + as ([...,]*) if -fugly-assumed, so assumed-size array + detected early enough. + +Thu Dec 19 14:01:57 1996 Craig Burley + + * target.h (FFETARGET_REAL_VALUE_FROM_INT_): Conditionalize + definition on BUILT_FOR_280, not BUILT_WITH_280, since + the name of the macro was (properly) changed since 0.5.19. + + Fix warnings/errors resulting from ffetargetOffset becoming + `long long int' instead of `unsigned long' as of 0.5.19, + while ffebitCount remains `unsigned long': + * bld.c (ffebld_constantarray_dump): Avoid warnings by + using loop var of appropriate type, and using casts. + * com.c (ffecom_expr_): Use right type for loop var. + (ffecom_sym_transform_, ffecom_transform_equiv_): + Cast to right type in assertions. + * data.c (ffedata_gather_, ffedata_value_): Cast to right + type in assertions and comparisons. + +Wed Dec 18 12:07:11 1996 Craig Burley + + Patch from Alexandre Oliva : + * Makefile.in (all.indirect): Don't pass -bbigtoc option + to GNU ld. + + Cope with new versions of gcc: + * com.h (BUILT_FOR_280): New macro. + * com.c (ffecom_ptr_to_expr): Conditionalize test of + OFFSET_REF. + (ffecom_build_complex_constant_): Conditionalize calling + sequence for build_complex. + +Sat Dec 7 07:15:17 1996 Craig Burley + + * Version 0.5.19 released. + +Fri Dec 6 12:23:55 1996 Craig Burley + + * g77.c: Default to assuming "f77" is in $LANGUAGES, since + the LANGUAGE_F77 macro isn't defined by anyone anymore (but + might as well leave the no-f77 code in just in case). + * Make-lang.in (g77, g77-cross): Don't define LANGUAGE_F77 + anymore. + +1996-12-06 Dave Love + + * Make-lang.in (g77, g77-cross): Revert to building `g77' or not + conditional on `f77' in LANGUAGES. + +Wed Dec 4 13:08:44 1996 Craig Burley + + * Make-lang.in (g77, g77-cross): No libs or lib dependencies + in case where "f77" is not in $LANGUAGES. + + * lex.c (ffelex_image_char_, ffelex_file_fixed, + ffelex_file_free): Fixes to properly handle lines with + null character, and too-long lines as well. + + * lex.c: Call ffebad_start_msg_lex instead of + ffebad_start_msg throughout. + +Sun Dec 1 21:19:55 1996 Craig Burley + + Fix-up for 1996-11-25 changes: + * com.c (ffecom_member_phase2_): Subtract out 0 offset for + elegance and consistency with EQUIVALENCE aggregates. + (ffecom_sym_transform_): Ditto for LOCAL/COMMON, and + ensure we get the same parent storage area. + * data.c (ffedata_gather_, ffedata_value_): Subtract out + aggregate offset. + +Wed Nov 27 13:55:57 1996 Craig Burley + + * proj.h: Quote the text of the #error message, to avoid + strange-looking diagnostics from non-gcc ANSI compilers. + + * top.c: Make -fno-debug-kludge the default. + +Mon Nov 25 20:13:45 1996 Craig Burley + + Provide more info on EQUIVALENCE mismatches: + * bad.def (FFEBAD_EQUIV_MISMATCH): More detailed message. + * equiv.c (ffeequiv_layout_local_, ffeequiv_layout_cblock): + More details for FFEBAD_EQUIV_MISMATCH. + + Fix problem with EQUIVALENCE handling: + * equiv.c (ffeequiv_layout_local_): Redesign algorithm -- + old one was broken, resulting in rejection of good code. + (ffeequiv_offset_): Add argument, change callers. + Clean up the code, fix up the (probably unused) negative-value + case for SYMTER. + * com.c (ffecom_sym_transform_): For local EQUIVALENCE + member, subtract out aggregate offset (which is <= 0). + +Thu Nov 21 12:44:56 1996 Craig Burley + + Change type of ffetargetOffset from `unsigned long' to `long long': + * bld.c (ffebld_constantarray_dump): Change printf formats. + * storag.c (ffestorag_dump): Ditto. + * symbol.c (ffesymbol_report): Ditto. + * target.h (ffetargetOffset_f): Ditto and change type itself. + + Handle situation where list of languages does not include f77: + * Make-lang.in: Define LANGUAGE_F77 to 1 only if `f77' is in + the $LANGUAGES macro for the build. + * g77.c: Compile to a (nearly) no-op program if LANGUAGE_F77 + is not defined to 1. + + Fixes to delay confirmation of READ, WRITE, and GOTO statements + so the corresponding assignments to same-named CHAR*(*) arrays + work: + * stb.c (ffestb_R90915_, ffestb_91014_): New functions. + (ffestb_goto3_, ffestb_goto5_): Move confirmation from 3 to 5 + for the OPEN_PAREN case. + (ffestb_R9091_, ffestb_R9094_, ffestb_R90913_, ffestb_R90914_, + ffestb_R91012_, ffestb_R91013_): Use new functions, and confirm + except for the OPEN_PAREN case. + + Fixes to not confirm declarations with an open paren where + an equal sign or other assignment-like token might be, so the + corresponding assignments to same-named CHAR*(*) arrays work: + (ffestb_decl_entsp_5_): Move assertion so we crash on that first, + if it turns out to be wrong, before the less-debuggable crash + on mistaken confirmation. + (ffestb_decl_entsp_6_, ffestb_decl_entsp_7_, ffestb_decl_entsp_8_): + Include OPEN_PAREN in list of assignment-only tokens. + + Fix more diagnosed-crash bugs: + * stu.c (ffestu_sym_end_transition): ANY-ize an adjustable array + with bad dimension expressions even if still stateUNCERTAIN. + (ffestu_symter_end_transition_, ffestu_symter_exec_transition_): + Return TRUE for opANY as well. + For code elegance, move opSYMTER case into first switch. + +1996-11-17 Dave Love + + * lex.c: Fix last change. + +1996-11-14 Dave Love + + * Make-lang.in, config-lang.in: Remove the (broken) libU77 stuff, + pending 0.5.20. + +Thu Nov 14 15:40:59 1996 Craig Burley + + * bad.def (FFEBAD_UNIMPL_STMT): Explain that invalid + intrinsic references can trigger this message, too. + +1996-11-12 Dave Love + + * lex.c: Declare dwarfout routines. + + * config-lang.in: Sink grep o/p. + +Mon Nov 11 14:21:13 1996 Craig Burley + + * g77.c (main): Might as well print version number + for --verbose as well. + +Thu Nov 7 18:41:41 1996 Craig Burley + + * expr.c, lang-options.h, target.h, top.c, top.h: Split out + remaining -fugly stuff into -fugly-logint and -fugly-comma, + leaving -fugly as simply a `macro' that expands into other + options, and eliminate defaults for some of the ugly stuff + in target.h. + + * Make-lang.in (gcc-cross): Compile zzz.c, not version.o (!), + in to get version info for this target. + + * config-lang.in: Test for GBE patch application based + on whether 2.6.x or 2.7.x GBE is detected. + +Wed Nov 6 14:19:45 1996 Craig Burley + + * Make-lang.in (g77): Compile zzz.c in to get version info. + * g77.c: Add support for --help and --version. + + * g77.c (lookup_option): Short-circuit long-winded tests + when second char is not hyphen, just to save a spot of time. + +Sat Nov 2 13:50:31 1996 Craig Burley + + * intrin.def: Add FTELL and FSEEK intrinsics, plus new + `g' codes for alternate-return (GOTO) arguments. + * intrin.c (ffeintrin_check_): Support `g' codes. + * com-rt.def: Add ftell_() and fseek_() to database. + * com.c (ffecom_expr_intrinsic_): Ditto. Also, let each + subroutine intrinsic decide for itself what to do with + tree_type, the default being NULL_TREE once again (so + ffecom_call_ doesn't think it's supposed to cast the + function call to the type in the fall-through case). + + * ste.c (ffeste_R909_finish): Don't special-case list-directed + I/O, now that libf2c can return non-zero status codes. + (ffeste_R910_finish): Ditto. + (ffeste_io_call_): Simplify logic. + (ffeste_io_impdo_): + (ffeste_subr_beru_): + (ffeste_R904): + (ffeste_R907): + (ffeste_R909_start): + (ffeste_R909_item): + (ffeste_R909_finish): + (ffeste_R910_start): + (ffeste_R910_item): + (ffeste_R910_finish): + (ffeste_R911_start): + (ffeste_R923A): Ditto all the above. + +Thu Oct 31 20:56:28 1996 Craig Burley + + * config-lang.in, Make-lang.in: Rename flag file + build-u77 to build-libu77, for consistency with + install-libf2c and such. + + * config-lang.in: Don't complain about failure to patch + if pre-2.7.0 gcc is involved (since our patch for that + doesn't add support for tooning). + +Sat Oct 26 05:56:51 1996 Craig Burley + + * bad.def (FFEBAD_TYPELESS_TOO_LARGE): Remove this + unused and redundant diagnostic. + +Sat Oct 26 00:45:42 1996 Craig Burley + + * target.c (ffetarget_integerhex): Fix dumb bug. + +1996-10-20 Dave Love + + * gbe/2.7.2.1.diff: New file. + + * Makefile.in (F771_LDFLAGS): Add -bbigtoc for AIX4.1 up, suggested by + endo@material.tohoku.ac.jp [among others!]. + +Sat Oct 19 03:11:14 1996 Craig Burley + + * bad.def, bld.c, bld.h, expr.c, lang-options.h, target.c, + target.h, top.c, top.h (ffebld_constant_new_integerbinary, + ffebld_constant_new_integerhex, ffebld_constant_new_integeroctal, + ffeexpr_token_name_apos_name_, ffetarget_integerbinary, + ffetarget_integerhex, ffetarget_integeroctal): Support + new -fno-typeless-boz option with new functions, mods to + existing octal-handling functions, new macros, new error + messages, and so on. + + * com.c, lang-options.h, top.c, top.h (ffecom_notify_primary_entry): + Print program unit name on stderr if -fno-silent (new option). + + * lang-options.h, top.c, top.h, stt.c (ffestt_dimlist_as_expr): + Treat ([...,]1) in dimlist as ([...,]*) if -fugly-assumed + (new option). + + * lang-options.h: Comment out options duplicated in gcc/toplev.c, + because, somehow, having them commented in and building on my + DEC Alpha results in a cc1 that always segfaults, and gdb that + also segfaults whenever it debugs it up to init_lex() calling + xmalloc() or so. + +Thu Oct 17 00:39:27 1996 Craig Burley + + * stb.c (ffestb_R10013_): Don't change meaning of .sign until + after previous meaning/value used to set sign of value + (960507-1.f). + +Sun Oct 13 22:15:23 1996 Craig Burley + + * top.c (ffe_decode_option): Don't set back-end flags + that are nonexistent prior to gcc 2.7.0. + +Sun Oct 13 12:48:45 1996 Craig Burley + + * com.c (convert): Don't convert emulated complex expr to + real (via REALPART_EXPR) if the target type is (emulated) + complex. + +Wed Oct 2 21:57:12 1996 Craig Burley + + * com.c (ffecom_debug_kludge_): Set DECL_IN_SYSTEM_HEADER so + -Wunused doesn't complain about these manufactured decls. + (ffecom_expr_): Ditto, for original (non-ASSIGN'ed) variable. + (ffecom_transform_equiv_): Clear DECL_IGNORED_P for aggregate + area so it shows up as a debug-accessible symbol. + (pushdecl): Default for "invented" identifiers (a g77-specific + concept for now) is that they are artificial, in system header, + ignored for debugging purposes, used, and (for types) suppressed. + This ought to be overkill. + +Fri Sep 27 23:13:07 1996 Craig Burley + + * ste.c (ffeste_begin_iterdo_, ffeste_end_iterdo_): Support + one-trip DO loops (F66-style). + * lang-options.h, top.c, top.h (-fonetrip): New option. + +Thu Sep 26 00:18:40 1996 Craig Burley + + * com.c (ffecom_debug_kludge_): New function. + (ffecom_sym_transform_): Use new function for COMMON and EQUIVALENCE + members. + + * lang-options.h, top.c, top.h (-fno-debug-kludge): + New option. + +1996-09-24 Dave Love + + * Make-lang.in (include/f2c.h): + Remove dependencies on xmake_file and tmake_file. + They expand inconsistently in 2.8 c.f. 2.7; $(GCC_PARTS) depends on + them anyhow. + +1996-09-22 Dave Love + + * config-lang.in: Add --enable-libu77 option handling. + + * Make-lang.in: + Conditionally add --enable-libu77 when running runtime configure. + Define LIBU77STAGESTUFF and use it in relevant rules. + +1996-08-21 Dave Love + + * Make-lang.in (f77-runtime): + `stmp-hdrs' should have been `stmp-headers'. + +1996-08-20 Dave Love + + * Make-lang.in (f77-runtime): + Depend on stmp-hdrs, not stmp-int-hdrs, since libF77 + needs float.h. + +Sat Jun 22 18:17:11 1996 Craig Burley + + * com.c (ffecom_tree_divide_): Fix RECORD_TYPE case to + look at type of first field, properly, to determine + whether to call c_div or z_div. + +Tue Jun 4 04:27:18 1996 Craig Burley + + * com.c (ffecom_build_complex_constant_): Explicitly specify + TREE_PURPOSE. + (ffecom_expr_): Fix thinko. + (ffecom_2): For COMPLEX_EXPR, explicitly specify TREE_PURPOSE. + +Mon May 27 16:23:43 1996 Craig Burley + + Changes to optionally avoid gcc's back-end complex support: + * com.c (ffecom_stabilize_aggregate_): New function. + (ffecom_convert_to_complex_): New function. + (ffecom_make_complex_type_): New function. + (ffecom_build_complex_constant_): New function. + (ffecom_expr_): For opCONVERT of non-COMPLEX to COMPLEX, + don't bother explicitly converting to the subtype first, + because gcc does that anyway, and more code would have + to be added to find the subtype for the emulated-complex + case. + (ffecom_f2c_make_type_): Use ffecom_make_complex_type_ + instead of make_node etc. to make a complex type. + (ffecom_1, ffecom_2): Translate operations on COMPLEX operands + to appropriate operations when emulating complex. + (ffecom_constantunion): Use ffecom_build_complex_constant_ + instead of build_complex to build a complex constant. + (ffecom_init_0): Change point at which types are laid out + for improved consistency. + Use ffecom_make_complex_type_ instead of make_node etc. + to make a complex type. + Always calculate storage sizes from TYPE_SIZE, never TYPE_PRECISION. + (convert): Use e, not expr, since we've copied into that anyway. + For RECORD_TYPE cases, do emulated-complex conversions. + (ffecom_f2c_set_lio_code_): Always calculate storage sizes + from TYPE_SIZE, never TYPE_PRECISION. + (ffecom_tree_divide_): Allow RECORD_TYPE to also be handled + by run-time library. + (ffecom_expr_intrinsic_): Handle possible RECORD_TYPE as argument + to AIMAG intrinsic. + + * top.h, top.c, lang-options.h: Support new -f(no-)emulate-complex option. + + * com.c (ffecom_sym_transform_): Clarify and fix typos in comments. + +Mon May 20 02:06:27 1996 Craig Burley + + * target.h: Use new REAL_VALUE_UNTO_TARGET_* macros instead + of REAL_VALUE_FROM_TARGET_DOUBLE and _SINGLE. + Explicitly use long instead of HOST_WIDE_INT for emulation + of ffetargetReal1 and ffetargetReal2. + +1996-05-20 Dave Love + + * config-lang.in: + Test for patch being applied with flag_move_all_movables in toplev.c. + + * install.texi (Patching GNU Fortran): + Mention overriding X_CFLAGS rather than + editing proj.h on SunOS4. + + * Make-lang.in (F77_FLAGS_TO_PASS): + Add X_CFLAGS (convenient for SunOS4 kluge, in + particular). + (f77.{,mostly,dist}clean): Reorder things, in particular not to delete + Makefiles too early. + + * g77.c (DEFAULT_SWITCH_TAKES_ARG): Define a la gcc.c in the + current GCC snapshot. + +Tue May 14 00:24:07 1996 Craig Burley + + Changes for DEC Alpha AXP support: + * com.c (ffecom_init_0): REAL_ARITHMETIC means internal + REAL/DOUBLE PRECISION might well have a different size + than the compiled type, so don't crash if this is the + case. + * target.h: Use `int' for ffetargetInteger1, + ffetargetLogical1, and magical tests. Set _f format + strings accordingly. + +Tue Apr 16 14:08:28 1996 Craig Burley + + * top.c (ffe_decode_option): -Wall no longer implies + -Wsurprising. + +Sat Apr 13 14:50:06 1996 Craig Burley + + * com.c (ffecom_char_args_): If item is error_mark_node, + set *length that way, too. + + * com.c (ffecom_expr_power_integer_): If either operand + is error_mark_node, return that. + + * com.c (ffecom_intrinsic_len_): If item is error_mark_node, + return that for length. + + * expr.c (ffeexpr_declare_unadorned_, + ffeexpr_declare_parenthesized_): Instead of crashing + on unexpected contexts, produce a diagnostic. + + * intrin.c (ffeintrin_check_), intrin.def (impSIGNAL): + Allow procedure as second arg to SIGNAL intrinsic. + + * stu.c (ffestu_symter_end_transition_): New function. + (ffestu_symter_exec_transition_): Return bool arg. + Always transition symbol (don't inhibit when !whereNONE). + (ffestu_sym_end_transition): If DUMMY/LOCAL arg has any + opANY exprs in its dimlist, diagnose it so it doesn't + make it through to later stages that try to deal with + dimlist stuff. + (ffestu_sym_exec_transition): If sym has any opANY exprs + in its dimlist, diagnose it so it becomes opANY itself. + + * symbol.c (ffesymbol_error): If token arg is NULL, + just ANY-ize the symbol -- don't produce diagnostic. + +Mon Apr 1 10:14:02 1996 Craig Burley + + * Version 0.5.18 released. + +Mon Mar 25 20:52:24 1996 Craig Burley + + * com.c (ffecom_expr_power_integer_): Don't generate code + that compares COMPLEX (or, as it happens, REAL) via "LT_EXPR", + since the back end crashes on that. (This code would never + be executed anyway, but the test that avoids it has now been + translated to control whether the code gets generated at all.) + Fixes 960323-3.f. + + * com.c (ffecom_type_localvar_): Handle variable-sized + dimension bounds expressions here, so they get calculated + and saved on procedure entry. Fixes 960323-4.f. + + * com.c (ffecom_notify_init_symbol): Symbol has no init + info at all if only zeros have been used to initialize it. + Fixes 960324-0.f. + + * expr.c, expr.h (ffeexpr_type_combine): Renamed from + ffeexpr_type_combine_ and now a public procedure; last arg now + a token, instead of an internal structure used to extract a token. + Now allows the outputs to be aliased with the inputs. + Now allows a NULL token to mean "don't report error". + (ffeexpr_reduced_bool2_, ffeexpr_reduced_eqop2_, + ffeexpr_reduced_math2_, ffeexpr_reduced_power_, + ffeexpr_reduced_relop2_): Handle new calling sequence for + ffeexpr_type_combine. + * (ffeexpr_convert): Don't put an opCONVERT node + in just because the size is unknown; all downstream code + should be able to deal without it being there anyway, and + getting rid of it allows new intrinsic code to more easily + combine types and such without generating bad code. + * info.c, info.h (ffeinfo_kindtype_max): Rewrite to do + proper comparison of size of types, not just comparison + of their internal kind numbers (so I2.eq.I1 doesn't promote + I1 to I2, rather the other way around). + * intrin.c (ffeintrin_check_): Combine types of arguments + in COL a la expression handling, for greater flexibility + and permissiveness (though, someday, -fpedantic should + report use of this kind of thing). + Make sure Hollerith/typeless where CHARACTER expected is + rejected. This all fixes 960323-2.f. + + * ste.c (ffeste_begin_iterdo_): Fix some more type conversions + so INTEGER*2-laden DO loops don't crash at compile time on + certain machines. Believed to fix 960323-1.f. + + * stu.c (ffestu_sym_end_transition): Certainly reject + whereDUMMY not in any dummy list, whether stateUNCERTAIN + or stateUNDERSTOOD. Fixes 960323-0.f. + +Tue Mar 19 13:12:40 1996 Craig Burley + + * data.c (ffedata_value): Fix crash on opANY, and simplify + the code at the same time. + + * Make-lang.in (f77-runtime): Also depends on lib[FI]77/Makefile... + (include/f2c.h...): ...which in turn depend on */Makefile.in. + (f77.rebuilt): Rebuild runtime stuff too. + + * intrin.c (ffeintrin_check_): Accommodate TYPELESS/HOLLERITH + types, convert args as necessary, etc. + + * expr.c (ffeexpr_convert): Fix test for TYPELESS/HOLLERITH + to obey the docs; crash if no source token when error. + (ffeexpr_collapse_convert): Crash if no token when error. + +Mon Mar 18 15:51:30 1996 Craig Burley + + * com.c (ffecom_init_zero_): Renamed from + ffecom_init_local_zero_; now handles top-level + (COMMON) initializations too. + + * bld.c (ffebld_constant_is_zero): + * com.c (ffecom_symbol_transform_, ffecom_sym_transform_assign_, + ffecom_transform_common_, ffecom_transform_equiv_): + * data.c: + * equiv.c: + * equiv.h: + * lang-options.h: + * stc.c: + * storag.c: + * storag.h: + * symbol.c: + * symbol.h: + * target.c: + * target.h: + * top.c: + * top.h: All of this is mostly housekeeping-type changes + to support -f(no-)zeros, i.e. not always stuff zero + values into the initializer fields of symbol/storage objects, + but still track that they have been given initial values. + + * bad.def: Fix wording for DATA-related diagnostics. + + * com.c (ffecom_sym_transform_assign_): Don't check + any EQUIVALENCE stuff for local ASSIGN, the check was + bad (crashing), and it's not necessary, anyway. + + * com.c (ffecom_expr_intrinsic_): For MAX and MIN, + ignore null arguments as far arg[123], and fix handling + of ANY arguments. (New intrinsic support now allows + spurious trailing null arguments.) + + * com.c (ffecom_init_0): Add HOLLERITH (unsigned) + equivalents for INTEGER*2, *4, and *8, so shift intrinsics + and other things that need unsigned versions of signed + types work. + +Sat Mar 16 12:11:40 1996 Craig Burley + + * storag.c (ffestorag_exec_layout): Treat adjustable + local array like dummy -- don't create storage object. + * com.c (ffecom_sym_transform_): Allow for NULL storage + object in LOCAL case (adjustable array). + +Fri Mar 15 13:09:41 1996 Craig Burley + + * com.c (ffecom_sym_transform_): Allow local symbols + with nonconstant sizes (adjustable local arrays). + (ffecom_type_localvar_): Allow dimensions with nonconstant + component (adjustable local arrays). + * expr.c: Various minor changes to handle adjustable + local arrays (a new case of stateUNCERTAIN). + * stu.c (ffestu_sym_end_transition, + ffestu_sym_exec_transition): Ditto. + * symbol.def: Update docs to reflect these changes. + + * com.c (ffecom_expr_): Reduce space/time needed for + opACCTER case by handling it here instead of converting + it to opARRTER earlier on. + (ffecom_notify_init_storage): Don't convert ACCTER to ARRTER. + (ffecom_notify_init_symbol): Ditto. + + * com.c (ffecom_init_0): Crash and burn if any of the types' + sizes, according to the GBE, disagrees with the sizes of + the FFE's internal implementation. This might catch + Alpha/SGI bugs earlier. + +Fri Mar 15 01:09:41 1996 Craig Burley + + * com-rt.def, com.c, com.h: Changes for rewrite of intrinsic + handling. + * com.c (ffecom_arglist_expr_): New function. + (ffecom_widest_expr_type_): New function. + (ffecom_expr_intrinsic_): Reorganize, some rewriting. + (ffecom_f2c_make_type_): Layout complex types. + (ffecom_gfrt_args_): New function. + (ffecom_list_expr): Trivial change for consistency. + + * expr.c (ffeexpr_token_name_rhs_): Go back to getting + type from specific, not implementation, info. + (ffeexpr_token_funsubstr_): Set intrinsic implementation too! + * intrin.c: Major rewrite of most portions. + * intrin.def: Major rearchitecting of tables. + * intrin.h (ffeintrin_basictype, ffeintrin_kindtype): + Now (once again) take ffeintrinSpec as arg, not ffeintrinImp; + for now, these return NONE, since they're not really needed + and adding the necessary info to the tables is not trivial. + (ffeintrin_codegen_imp): New function. + * stc.c (ffestc_R1208_item): Change way ffeintrin funcs called, + back to original per above; but comment out the code anyway. + + * intrin.c (ffe_init_0): Do internal checks only if + -fset-g77-defaults not specified. + + * lang-options.h: Add -fset-g77-defaults option. + * lang-specs.h: Always pass -fset-g77-defaults. + * top.c, top.h: New option. + +Sat Mar 9 17:49:50 1996 Craig Burley + + * Make-lang.in (stmp-int-hdrs): Use --no-validate when + generating the f77.rebuilt files (BUGS, INSTALL, NEWS) + so cross-references can work properly in g77.info + without a lot of hassle. Users can probably deal with + the way they end up looking in the f77.rebuilt files. + + * bld.c (ffebld_constant_new_integer4_val): INTEGER*8 + support -- new function. + (ffebld_constant_new_logical4_val): New function. + * com.c (ffecom_f2c_longint_type_node): New type. + (FFECOM_rttypeLONGINT_): New return type code. + (ffecom_expr_): Add code to invoke pow_qq instead + of pow_ii for INTEGER4 (INTEGER*8) case. + If ffecom_expr_power_integer_ returns NULL_TREE, just do + the usual work. + (ffecom_make_gfrt_): Handle new type. + (ffecom_expr_power_integer_): Let caller do the work if in + dummy-transforming case, since + caller now knows about INTEGER*8 and such, by returning + NULL_TREE. + * expr.c (ffeexpr_reduced_power_): Complain about non-INTEGER + raised to INTEGER4 (INTEGER*8) power. + + * target.c (ffetarget_power_integerdefault_integerdefault): + Fix any**negative. + * com.c (ffecom_expr_power_integer_): Fix (-1)**(-8) and similar + to ABS() the integral result if the exponent is negative + and even. + + * ste.c (ffeste_begin_iterdo_): Clean up a type ref. + Always convert iteration count to _default_ INTEGER. + + * sta.c (ffesta_second_): Add BYTE and WORD type/stmts; + changes by Scott Snyder . + * stb.c (ffestb_decl_recursive): Ditto. + (ffestb_decl_recursive): Ditto. + (ffestb_decl_entsp_2_): Ditto. + (ffestb_decl_entsp_3_): Ditto. + (ffestb_decl_funcname_2_): Ditto. + (ffestb_decl_R539): Ditto. + (ffestb_decl_R5395_): Ditto. + * stc.c (ffestc_establish_declstmt_): Ditto. + * std.c (ffestd_R539item): Ditto. + (ffestd_R1219): Ditto. + * stp.h: Ditto. + * str-1t.fin: Ditto. + * str-2t.fin: Ditto. + + * expr.c (ffeexpr_finished_): For DO loops, allow + any INTEGER type; convert LOGICAL (assuming -fugly) + to corresponding INTEGER type instead of always default + INTEGER; let later phases do conversion of DO start, + end, incr vars for implied-DO; change checks for non-integral + DO vars to be -Wsurprising warnings. + * ste.c (ffeste_io_impdo_): Convert start, end, and incr + to type of DO variable. + + * com.c (ffecom_init_0): Add new types for [IL][234], + much of which was done by Scott Snyder . + * target.c: Ditto. + * target.h: Ditto. + +Wed Mar 6 14:08:45 1996 Craig Burley + + * top.c (ffe_init_gbe_): Make -frerun-loop-opt the default. + +Mon Mar 4 12:27:00 1996 Craig Burley + + * expr.c (ffeexpr_exprstack_push_unary_): Really warn only + about two successive _arithmetic_ operators. + + * stc.c (ffestc_R522item_object): Allow SAVE of (understood) + local entity. + + * top.c (ffe_decode_option): New -f(no-)second-underscore options. + * top.h: New options. + * com.c (ffecom_get_external_identifier_, ffecom_get_identifier_): + New options. + + * Make-lang.in (f77.maintainer-clean): Clean f/BUGS, f/INSTALL, + f/NEWS. + ($(srcdir)/f/BUGS, $(srcdir)/f/INSTALL, $(srcdir)/f/NEWS): + New rules. + ($(srcdir)/f/g77.info, $(srcdir)/f/g77.dvi): Depend on + f/bugs.texi and f/news.texi. + (f77.install-man): Install f77 man pages (if enabled). + (f77.uninstall): Uninstall info docs, f77 man pages (if enabled). + + * top.c (ffe_init_gbe_): New function. + (ffe_decode_option, ffe_file): Call ffe_init_gbe_ to + set defaults for gcc options. + +Sat Jan 20 13:57:19 1996 Craig Burley + + * com.c (ffecom_get_identifier_): Eliminate needless + comparison of results of strchr. + +Tue Dec 26 11:41:56 1995 Craig Burley + + * Make-lang.in: Add rules for new files g77.texi, g77.info, + and g77.dvi. + Reorganize the *clean rules to more closely parallel gcc's. + + * config-lang.in: Exclude g77.info from diffs. + +Sun Dec 10 02:29:13 1995 Craig Burley + + * expr.c (ffeexpr_declare_unadorned_, + ffeexpr_declare_parenthesized_): Break out handling of + contextDATAIMPDO[INDEX,CTRL] so it's independent of symbol state. + Don't exec-transition these here (let ffeexpr_sym_impdoitem_ + handle that when appropriate). Don't "declare" them twice. + +Tue Dec 5 06:48:26 1995 Craig Burley + + * stc.c (ffestc_promote_sfdummy_): Allow whereNONE parent + symbol, since it is not necessarily known whether it will + become LOCAL or DUMMY. + +Mon Dec 4 03:46:55 1995 Craig Burley + + * lex.c (ffelex_display_token, ffelex_type_string_): Resurrect + these from their old versions and update them for possible invocation + from debugger. + * lex.h (ffelex_display_token): Declare this in case anyone + else wants to call it. + + * lex.c (ffelex_total_tokens_): Have this reflect actual allocated + tokens, no longer include outstanding "uses" of tokens. + + * malloc.c, malloc.h (MALLOC_DEBUG): New macro to control + checking of whether callers follow rules, now defaults to 0 + for "no checking" to improve compile times. + + * malloc.c (malloc_pool_kill): Fix bug that could prevent + subpool from actually being killed (wasn't setting its use + count to 1). + + * proj.h, *.c (dmpout): Replace all occurrences of `stdout' + and some of `stderr' with `dmpout', so where to dump debugging + output can be easily controlled during build; add default + for `dmpout' of `stderr' to proj.h. + +Sun Dec 3 00:56:29 1995 Craig Burley + + * com.c (ffecom_return_expr): Eliminate attempt at warning + about unset return values, since the back end does this better, + with better wording, and is not triggered by clearly working + (but spaghetti) code as easily as this test. + +Sat Dec 2 08:28:56 1995 Craig Burley + + * target.c (ffetarget_power_*_integerdefault): Raising 0 to + integer constant power should not be an error condition; + if so, other code should catch 0 to any power, etc. + + * bad.def (FFEBAD_BAD_POWER): 0**integer now a warning instead + of an error. + +Fri Dec 1 00:12:03 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * bad.def: Clarify diagnostic regarding complex constant elements. + * expr.c (ffeexpr_cb_comma_c_): Capitalize real/imaginary + for clarified diagnostic. + + * com.c (ffecom_close_include_): Close the file! + + * lex.c (ffelex_file_fixed): Update line info if the line + has any content, not just if it finishes a previous line + or has a label. + (ffelex_file_free): Clarify switch statement code. + +Sat Nov 18 19:37:22 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.17 released. + +Fri Nov 17 14:27:24 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Make-lang.in: Fix typo in comment. + + * Makefile.in (f/fini.o, f/proj-h.o): Don't use `$<' since + not all makes support it (e.g. NeXT make), use explicit + source name instead (with $(srcdir) and munging). + (ASSERT_H): assert.h lives in source dir, not build dir. + +Thu Nov 16 12:47:50 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * com.c (ffecom_init_0): Fix dumb bug in code to produce + warning message about non-32-bit-systems. + + * stc.c (ffestc_R501_item): Parenthesize test to make + warning go away (and perhaps fix bug). + +Thu Nov 16 03:43:33 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * g77.c: Upgrade to 2.7.0's gcc.c. + Fix -v to pass a temp name instead of "/dev/null" for "-o". + +Fri Nov 10 19:16:05 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * ste.c (ffeste_begin_iterdo_): Add Toon's change to + make loops faster on some machines (implement termination + condition as "--i >= 0" instead of "i-- > 0"). + +Thu Nov 2 03:58:17 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Make-lang.in: Remove unnecessary $(exeext) a la cp/Make-lang.in. + + * com.c (ffecom_expr_): Restore old strategy for assignp variant + of opSYMTER case...always return the ASSIGN version of var. + That way, `-O -Wuninitialized' will catch "I=3;GOTO I;END" + (though the diagnostic will refer to `__g77_ASSIGN_i'). + + * com.c (ffecom_expr_power_integer_): For constant rhs case, + wrap every new eval of lhs in save_expr() so it is clear to + back end that MULT_EXPR(lhs,lhs) has identical operands, + otherwise for an rhs like 32767 it generates around 65K pseudo + registers, which which stupid_life_analysis cannot cope + (due to reg_renumber in regs.h being `short *' instead of + `int *'). + + * com.c (ffecom_expr_): Speed up implementation of LOGICAL + versions of opNOT, opAND, opOR, opXOR/opNEQV, and opEQV by + assuming the values actually are kosher LOGICAL bit patterns. + Also simplify code that implements some of the INTEGER versions + of these. + + * com.c (skip_redundant_dir_prefix, read_name_map, + ffecom_open_include_, signed_type, unsigned_type): Fold in + changes to cccp.c made from 2.7.0 through ss-950826. + + * equiv.c (ffeequiv_layout_local_): Kill the equiv list + if no syms in list. + + * expr.c (ffeexpr_reduced_eqop2_): Issue specific diagnostic + regarding usage of .EQV./.NEQV. in preference to .EQ./.NE.. + + * intrin.c: Add ERF and ERFC as generic intrinsics. + intrin.def: Same. + + * sta.c (ffesta_save_, ffesta_second_): Whoever calls + ffestd_exec_begin must also set ffesta_seen_first_exec = TRUE, + and anytime stc sees an exec transition, it must do both. + stc.c (ffestc_eof): Same. + + * stc.c (ffestc_promote_sfdummy_): If failed implicit typing + or CHARACTER*(*) arg, after calling ffesymbol_error, don't + reset info to ENTITY/DUMMY, because ffecom_sym_transform_ + doesn't expect such a thing with ANY/ANY type. + + * target.h (*logical*): Change some of these so they parallel + changes in com.c, e.g. for _eqv_, use (l)==(r) instead of + !!(l)==!!(r), to get a more faithful result. + +Fri Oct 27 07:06:59 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * com.c (ffecom_sym_transform_): Simplify code for local + EQUIVALENCE case. + + * expr.c (ffeexpr_exprstack_push_unary_): Warn about two + successive operators. + (ffeexpr_exprstack_push_binary_): Warn about "surprising" + operator precedence, as in "-2**2". + + * lang-options.h: Add -W(no-)surprising options. + + * parse.c (yyparse): Don't reset -fpedantic if not -pedantic. + + * top.c (ffe_decode_option): Support new -Wsurprising option. + * top.h: Ditto. + +Mon Oct 23 09:14:15 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * com.c (ffecom_finish_symbol_transform_): Don't transform + NONE/NONE (CHARACTER*(*)) vars, as these don't mean anything + in debugging terms, and can't be turned into anything + in the back end (so ffecom_sym_transform_ crashes on them). + + * com.c (ffecom_expr_): Change strategy for assignp variant + of opSYMTER case...always return the original var unless + it is not wide enough. + + * ste.c (ffeste_io_cilist_): Clarify diagnostic for ASSIGN + involving too-narrow variable. This shouldn't happen, though. + (ffeste_io_icilist_): Ditto. + (ffeste_R838): Ditto. + (ffeste_R839): Ditto. + +Thu Oct 19 03:21:20 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * com.c (ffecom_sym_transform_assign_): Set TREE_STATIC + using the same decision-making process as used for their twin + variables, so ASSIGN can last across RETURN/CALL as appropriate. + +Fri Sep 22 20:21:18 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Makefile.in: fini is a host program, so it needs a host-compiled + version of proj.o, named proj-h.o. f/fini, f/fini.o, and + f/proj-h.o targets updated accordingly. + + * com.c (__eprintf): New function. + +Wed Sep 20 02:26:36 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * lang-options.h: Add omitted -funix-intrinsics-* options. + + * malloc.c (malloc_find_inpool_): Check for infinite + loop, crash if detected (user reports encountering + them in some large programs, this might help track + down the bugs). + +Thu Sep 7 13:00:32 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * com.c (lang_print_error_function): Don't dereference null + pointer when outside any program unit. + (ffecom_let_char_, ffecom_arg_ptr_to_expr): If catlist + item or length ever error_mark_node, don't continue processing, + since back-end functions like build_pointer_type crash on + error_mark_node's (due to pushing bad obstacks, etc.). + +Wed Aug 30 15:58:35 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.16 released. + +Mon Aug 28 12:24:20 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * bad.c (ffebad_finish): Fix botched message when no places + are printed (due to unknown line info, etc.). + + * std.c (ffestd_subr_labels_): Do a better job finding + line info in the case of typeANY and diagnostics. + +Fri Aug 25 15:19:29 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * com.c (DECL_ARTIFICIAL): Surround all references to this + macro with #if !BUILT_FOR_270 and #endif. + (init_lex): Surround print_error_function decl with + #if !BUILT_FOR_270 and #endif. + (lang_init): Call new ffelex_hash_kludge function to solve + problem with preprocessed files that have INCLUDE statements. + + * lex.c (ffelex_getc_): New function. + (ffelex_cfelex_): Use ffelex_getc_ instead of getc in any + paths of code that can be affected by ffelex_hash_kludge. + Don't make an EOF token for unrecognized token; set token + to NULL instead, to avoid problems when not initialized. + (ffelex_hash_): Use ffelex_getc_ instead of getc in any + paths of code that can be affected by ffelex_hash_kludge. + Test token returned by ffelex_cfelex_ for NULL, meaning + unrecognized token. + Get rid of useless used_up variable. + Don't do ffewhere stuff or kill any tokens if in + ffelex_hash_kludge. + (ffelex_file_fixed, ffelex_file_free): Use ffelex_getc_ + instead of getc in any paths of code that can be affected + by ffelex_hash_kludge. + (ffelex_hash_kludge): New function. + + * lex.h (ffelex_hash_kludge): New function. + +Wed Aug 23 15:17:40 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * com.c: Implement -f(no-)underscoring options by always + compiling in code to do it, and having that code inhibit + itself when -fno-underscoring is in effect. This option + overrides -f(no-)f2c for this purpose; -f(no-)f2c returns + to it's <=0.5.15 behavior of affecting only how code + is generated, not how/whether names are mangled. + + * target.h: Redo specification of appending underscores so + the macros are named "_default" instead of "_is" and the + two-underscore macro defaults to 1. + + * top.c, top.h (underscoring): Add appropriate stuff + for the -f(no-)underscoring options. + +Tue Aug 22 10:25:01 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * bad.c (ffebad_finish): Call report_error_function (in toplev.c) + to better identify location of problem. + Say "(continued):" instead of "(continued:)" for consistency. + + * com.c (ffecom_gen_sfuncdef_): Set and reset new + ffecom_nested_entry_ variable to hold ffesymbol being compiled. + (lang_print_error_function): New function from toplev.c. + Use ffecom_nested_entry_ to help determine which name + and kind-string to print. + (ffecom_expr_intrinsic_): Handle EXIT and FLUSH invocations + with different calling sequences than library functions. + Have SIGNAL and SYSTEM push and pop calltemps, and convert + their return values to the destination type (just in case). + (FFECOM_rttypeINT_): New return type for `int', in case + gcc/f/runtime/libF77/system_.c(system_) is really supposed + to return `int' instead of `ftnint'. + + * com.h (report_error_function): Declare this. + + * equiv.c (ffeequiv_layout_local_): Don't forget to consider + root variable itself as possible "first rooted variable", + else might never set symbol and then crash later. + + * intrin.c (ffeintrin_check_exit_): Change to allow no args + and rename to ffeintrin_check_int_1_o_ for `optional'. + #define ffeintrin_check_exit_ and _flush_ to this new + function, so intrin.def can refer to the appropriate names. + + * intrin.def (FFEINTRIN_impFLUSH): Validate using + ffeintrin_check_flush_ so passing an INTEGER arg is allowed. + + * lex.c (ffelex_file_push_, ffelex_file_pop_): New functions + to manage input_file_stack in gbe. + (ffelex_hash_): Call new functions (instead of doing code). + (ffelex_include_): Call new functions to update stack for + INCLUDE (_hash_ handles cpp output of #include). + +Mon Aug 21 08:09:04 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Makefile.in: Put `-W' in front of every `-Wall', since + 2.7.0 requires that to engage `-Wunused' for parameters. + + * com.c: Mark all parameters as artificial, so + `-W -Wunused' doesn't complain about unused ones (since + there's no way right not to individually specify attributes + like `unused'). + + * proj.h: Don't #define UNUSED if already defined, regardless + of host compiler. + +Sun Aug 20 16:03:56 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * gbe/2.7.0.diff: Regenerate. + + * lang-options.h, lang-specs.h: If not __STDC__ (ANSI C), + avoid doing anything, especially the stringizing in -specs.h. + +Thu Aug 17 03:36:12 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * lang-specs.h: Remove useless optional settings of -traditional, + since -traditional is always set anyway. + +Wed Aug 16 16:56:46 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Make-lang.in (F2C_INSTALL_FLAG, F2CLIBOK): More + control over whether to install f2c-related stuff. + (install-f2c-*): New targets to install f2c-related + stuff in system, not just gcc, directories. + + * com.c: Change calls to ffecom_get_invented_identifier + to use generally more predictable names. + Change calls to build_range_type to ensure consistency + of types of operands. + (ffecom_get_external_identifier_): Change to accept + symbol info, not just text, so it can use f2c flag for + symbol to decide whether to append underscore(s). + (ffecom_get_identifier_): Don't change names if f2c flag + off for compilation. + (ffecom_type_permanent_copy_): Use same type for new max as + used for min. + (ffecom_notify_init_storage): Offline fixups for stand-alone. + + * data.c (ffedata_gather): Explicitly test for common block, + since it's no longer always the case that a local EQUIVALENCE + group has no symbol ptr (it now can, if a user-predictable + "rooted" symbol has been identified). + + * equiv.c: Add some debugging stuff. + (ffeequiv_layout_local_): Set symbol ptr with user-predictable + "rooted" symbol, for giving the invented aggregate a + predictable name. + + * g77.c (append_arg): Allow for 20 extra args instead of 10. + (main): For version-only case, add `-fnull-version' and, unless + explicitly omitted, `-lf2c -lm'. + + * lang-options.h: New "-fnull-version" option. + + * lang-specs.h: Support ".fpp" suffix for preprocessed source + (useful for OS/2, MS-DOS, other case-insensitive systems). + + * stc.c (ffestc_R544_equiv_): Swap way lists are merged so this + is consistent with the order in which lists are built, making + user predictability of invented aggregate name much higher. + + * storag.c, storag.h (FFESTORAG_typeDUMMY): Delete this enum. + + * top.c: Accept, but otherwise ignore, `-fnull-version'. + +Tue Aug 15 07:01:07 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * DOC, INSTALL, PROJECTS: Extensive improvements to documentation. + +Sun Aug 13 01:55:18 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * INSTALL (f77-install-ok): Document the use of this file. + + * Make-lang.in (F77_INSTALL_FLAG): New flag to control + whether to install an `f77' command (based on whether + a file named `f77-install-ok' exists in the source or + build directory) to replace the broken attempt to use + comment lines to avoid installing `f77' (broken in the + sense that it prevented installation of `g77'). + +Mon Aug 7 06:14:26 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * DOC: Add new sections for g77 & gcc compiler options, + source code form, and types, sizes and precisions. + Remove lots of old "delta-version" info, or at least + summarize it. + + * INSTALL: Add info here that used to be in DOC. + Other changes. + + * g77.c (lookup_option, main): Check for --print-* options, + so we avoid adding version-determining stuff. + +Wed Jul 26 15:51:03 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Make-lang.in, Makefile.in (input.j, INPUT_H): New file. + Update dependencies accordingly. + + * bad.c (ffebad_here): Okay to use unknown line/col. + + * compilers.h (@f77-cpp-input): Remove -P option now that + # directives are handled by f771. Update other options + to be more consistent with @c in gcc/gcc.c. Don't run f771 + if -E specified, etc., a la @c. + (@f77): Don't run f771 if -E specified, etc., a la @c. + + * config-lang.in: Avoid use of word "guaranteed". + + * input.j: New file to wrap around gcc/input.h. + + * lex.j: Add support for parsing # directives output by cpp. + (ffelex_cfebackslash_): New function. + (ffelex_cfelex_): New function. + (ffelex_get_directive_line_): New function. + (ffelex_hash_): New function. + (ffelex_include_): Change to not use ffewhere_file_(begin|end). + Also fix bug in pointing to next line (for diagnostics, &c) + following successful INCLUDE. + (ffelex_next_line_): New function that does chunk of code + seen in several places elsewhere in the lexers. + (ffelex_file_fixed): Delay finishing statement until source + line is registered with ffewhere, so INCLUDE processing + picks up the info correctly. + Okay to kill or use unknown line/col objects now. + Handle HASH (#) lines. + Reorder tests for insubstantial lines to put most frequent + occurrences at top, for possible minor speedup. + Some general consolidation of code. + (ffelex_file_free): Handle HASH (#) lines. + Okay to kill or use unknown line/col objects now. + Some general consolidation of code. + (ffelex_init_1): Detect HASH (#) lines. + (ffelex_set_expecting_hollerith): Okay to kill or use unknown + line/col objects now. + + * lex.h (FFELEX_typeHASH): New enum. + + * options-lang.h (-fident, -fno-ident): New options. + + * stw.c (ffestw_update): Okay to kill unknown line/col objects + now. + + * target.h (FFETARGET_okREALQUAD, FFETARGET_okCOMPLEXDOUBLE, + FFETARGET_okCOMPLEXQUAD): #define these appropriately. + + * top.c: Include flag.j wrapper, not flags.h directly. + (ffe_is_ident_): New flag. + (ffe_decode_option): Handle -fident and -fno-ident. + (ffe_file): Replace obsolete ffewhere_file_(begin|end) with + ffewhere_file_set. + + * top.h (ffe_is_ident_, ffe_is_ident, ffe_set_is_ident): + New flag and access functions. + + * where.c, where.h: Remove all tracking of parent file. + (ffewhere_file_begin, ffewhere_file_end): Delete these. + (ffewhere_line_use): Make it work with unknown line object. + +Mon Jul 17 03:04:09 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * com.c (ffecom_sym_transform_): Set DECL_IN_SYSTEM_HEADER + flag for any local vars used as stmtfunc dummies or DATA + implied-DO iter vars, so no -Wunused warnings are produced + for them (a la f2c). + (ffecom_init_0): Do "extern int xargc;" for IARGC() intrinsic. + Warn if target machine not 32 bits, since g77 isn't yet + working on them at all well. + + * expr.c (ffeexpr_sym_lhs_call_, ffeexpr_sym_lhs_data_, + ffeexpr_sym_lhs_extfunc_, ffeexpr_sym_rhs_actualarg_, + ffeexpr_sym_rhs_let_, ffeexpr_paren_rhs_let_): Don't + gratuitously set attr bits that don't apply just + to avoid null set meaning error; instead, use explicit + error flag, and allow null attr set, to + fix certain bugs discovered by looking at this code. + + * g77.c: Major changes to improve support for gcc long options, + to make `g77 -v' report more useful info, and so on. + +Mon Jul 3 14:49:16 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * DOC, com.c, intrin.h, intrin.c, intrin.def, target.h, top.c, + top.h: Add new `unix' group of intrinsics, which includes the + newly added ERF, ERFC, EXIT, plus even newer ABORT, DERF, DERFC, + FLUSH, GETARG, GETENV, SIGNAL, and SYSTEM. + +Tue Jun 27 23:01:05 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * bld.c, bld.h (ffebld_constant_pool, + ffebld_constant_character_pool): Use a single macro (the + former) to access the pool for allocating constants, instead + of latter in public and FFEBLD_CONSTANT_POOL_ internally + in bld.c (which was the only one that was correct before + these changes). Add verification of integrity of certain + heap-allocated areas. + + * com.c (ffecom_overlap_, ffecom_args_overlap_, + ffecom_tree_canonize_ptr_, ffecom_tree_canonize_ref_): New + functions to optimize calling COMPLEX and, someday, CHARACTER + functions requiring additional argument to be passed. + (ffecom_call_, ffecom_call_binop_, ffecom_expr_, + ffecom_expr_intrinsic_): Change calling + sequences to include more info on possible destination. + (ffecom_expr_intrinsic_): Add ERF(), ERFC(), and EXIT() + intrinsic code. + (ffecom_sym_transform_): For assumed-size arrays, set high + bound to highest possible value instead of low bound, to + improve validity of overlap checking. + (duplicate_decls): If olddecl and newdecl are the same, + don't do any munging, just return affirmative. + + * expr.c: Change ffecom_constant_character_pool() to + ffecom_constant_pool(). + + * info.c (ffeinfo_new): Compile this version if not being + compiled by GNU C. + + * info.h (ffeinfo_new): Don't define macro if not being + compiled by GNU C. + + * intrin.c, intrin.def: Add ERF(), ERFC(), and EXIT() intrinsics. + (ffeintrin_check_exit_): New for EXIT() subroutine intrinsic. + + * malloc.c, malloc.h (malloc_verify_*): New functions to verify + integrity of heap-storage areas. + + * stc.c (ffestc_R834, ffestc_R835): Handle possibility that + an enclosing DO won't have a construct name even when the + CYCLE/EXIT does (i.e. without dereferencing NULL). + + * target.c, target.h (ffetarget_verify_character1): New function + to verify integrity of heap storage used to hold character constant. + +Thu Jun 22 15:36:39 1995 Howard Gordon (flash@super.org) + + * stp.h (ffestpVxtcodeIx): Fix typo in typedef for this. + +Mon May 29 15:22:31 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * *: Make all sorts of changes to accommodate upcoming gcc-2.7.0. + I didn't keep track of them, nor just when I made them, nor + when I (much later, probably in early August 1995) modified + them so they could properly handle both 2.7.0 and 2.6.x. + + * com.c (ffecom_expr_power_integer_): Don't expand_start_stmt_expr + if transforming dummy args, because the back end cannot handle + that (it's rejected by the gcc front end), just generate + call to run-time library. + Back out changes in 0.5.15 because more temporaries might be + needed anyway (for COMPLEX**INTEGER). + (ffecom_push_tempvar): Remove inhibitor. + Around start_decl and finish_decl (in particular, arround + expand_decl, which is called by them), push NULL_TREE into + sequence_rtl_expr, an external published by gcc/function.c. + This makes sure the temporary is truly in the function's + context, not the inner context of a statement-valued expression. + (I think the back end is inconsistent here, but am not + interested in convincing the gbe maintainers about this now.) + (pushdecl): Make sure that when pushing PARM_DECLs, nothing + other than them are pushed, as happened for 0.5.15 and which, + if done for other reasons not fixed here, might well indicate + some other problem -- so crash if it happens. + + * equiv.c (ffeequiv_layout_local_): If the local equiv group + has a non-nil COMMON field, it should mean that an error has + occurred and been reported, so just trash the local equiv + group and do nothing. + + * stc.c (ffestc_promote_sfdummy_): Set sfdummy arg state to + UNDERSTOOD so above checking for duplicate args actually + works, and so we don't crash later in pushdecl. + + * ste.c (ffeste_R1001): Set initial value only for VAR_DECLs, + not for, e.g., LABEL_DECLs, which the FORMAT label can be + if it was previously treated as an executable label. + +Sat May 20 01:53:53 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * com.c (ffecom_sym_transform_): For adjustable arrays, + pass high bound through variable_size in case its primaries + are changed (dumb0.f, and this might also improve + performance so it approaches f2c|gcc). + +Fri May 19 11:00:36 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.15 released. + + * com.c (ffecom_expr_power_integer_): Push temp vars + before expanding a statement expression, since that seems + to cause temp vars to be "forgotten" after the end of the + expansion in the back end. Disallow more temp-var + pushing during such an expansion, just in case. + (ffecom_push_tempvar): Crash if a new variable needs to be + pushed but cannot be at this point (should never happen). + +Wed May 17 12:26:16 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * expr.c (ffeexpr_collapse_convert): Add code to convert + LOGICAL to CHARACTER. Reject conversion of REAL or COMPLEX + to CHARACTER entirely, as it cannot be supported with all + configurations. + + * target.h, target.c (ffetarget_convert_character1_logical1): + New function. + +Sun May 14 00:00:09 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * com.c (ffecom_do_entry_, ffecom_gen_sfuncdef_, + ffecom_start_progunit_, ffecom_sym_transform_, + ffecom_init_0, start_function): Changes to have REAL + external functions return same type as DOUBLE PRECISION + external functions when -ff2c is in force; while at it, + some code cleanups done. + + * stc.c (ffestc_R547_item_object): Disallow array declarator + if one already exists for symbol. + + * ste.c (ffeste_R1227): Convert result variable to type + of function result as seen by back end (e.g. for when REAL + external function actually returns result as double). + + * target.h (FFETARGET_defaultFIXED_LINE_LENGTH): New + macro for default for -ffixed-line-length-N option. + + * top.c (ffe_fixed_line_length_): Initialize this to new + target.h macro instead of constant 72. + +Tue May 9 01:20:03 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * lex.c (ffelex_send_token_): If sending CHARACTER token with + null text field, put a single '\0' in it and set length/size + fields to 0 (to fix 950508-0.f). + (ffelex_image_char_): When setting ffelex_bad_line_ to TRUE, + always "close" card image by appending a null char and setting + ffelex_card_length_. As part of this, append useful text + to identify the two kinds of problems that involve this. + (ffelex_file_fixed): Reset ffelex_bad_line_ to FALSE after + seeing a line with invalid first character (fixes 950508-1.f). + If final nontab column is zero, assume tab seen in line. + (ffelex_card_image_): Always make this array 8 characters + longer than reflected by ffelex_card_size_. + (ffelex_init_1): Get final nontab column info from top instead + of assuming 72. + + * options-lang.h: Add -ffixed-line-length- prefix. + + * top.h: Add ffe_fixed_line_length() and _set_ version, plus + corresponding extern. + + * top.c: Handle -ffixed-line-length- option prefix. + +Fri Apr 28 05:40:25 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.14 released. + + * Make-lang.in: Add assert.j. + + * Makefile.in: Add assert.j. + + * assert.j: New file. + +Thu Apr 27 16:24:22 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * bad.h (ffebad_severity): New function. + + * bad.c (ffebad_severity): New function. + + * bad.def (FFEBAD_OPEN_INCLUDE): Change severity from SEVERE + to FATAL, since processing continues, and that seems fine. + + * com.c: Add facility to handle -I. + (ffecom_file, ffecom_close_include, ffecom_open_include, + ffecom_decode_include_option): New global functions for -I. + (ffecom_file_, ffecom_initialize_char_syntax_, + ffecom_close_include_, ffecom_decode_include_option_, + ffecom_open_include_, append_include_chain, open_include_file, + print_containing_files, read_filename_string, file_name_map, + savestring): New internal functions for -I. + + * compilers.h: Pass -I flag(s) to f771 (via "%{I*}"). + + * lex.c (ffelex_include_): Call ffecom_close_include + to close include file, for its tracking needs for -I, + instead of using fclose. + + * options-lang.h: Add -I prefix. + + * parse.c (yyparse): Call ffecom_file for main input file, + so -I handling works (diagnostics). + + * std.c (ffestd_S3P4): Have ffecom_open_include handle + opening and diagnosing errors with INCLUDE files. + + * ste.c (ffeste_begin_iterdo_): Use correct algorithm for + calculating # of iterations -- mathematically similar but + computationally different algorithm was not handling cases + like "DO I=6,5,2" correctly, because (5-6)/2+1 => 1, not 0. + + * top.c (ffe_decode_option): Allow -I, restructure a bit + for clarity and, maybe, speed. + +Mon Apr 17 13:31:11 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * g77.c: Remove -lc, turns out not all systems has it, but + leave other changes in for clarity of code. + +Sun Apr 16 21:50:33 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * com.c (ffecom_expr_): Implement ARRAY_EXPR as INDIRECT_REF + of appropriate PLUS_EXPRs of ptr_to_expr of array, to see + if this generates better code. (Conditional on + FFECOM_FASTER_ARRAY_REFS.) + +Sun Apr 16 00:22:48 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Make-lang.in (F77_SRCS): Remove g77.c, since it doesn't + contribute to building f771. + + * Makefile.in (dircheck): Remove/replace with f/Makefile, because + phony targets that are referenced in other real targets get run + when those targets are specified, which is a waste of time (e.g. + when rebuilding and only g77.c has changed, f771 was being linked + anyway). + + * g77.c: Include -lc between -lf2c and -lm throughout. + + * implic.c (ffeimplic_establish_symbol): If -Wimplicit, warn if + implicit type given to symbol. + + * lex.c (ffelex_include_): Don't gratuitously increment line + number here. + + * top.h, top.c (ffe_is_warn_implicit_): New global variable and + related access macros. + (ffe_decode_option): Handle -W options, including -Wall and + -Wimplicit. + + * where.c (ffewhere_line_new): Don't muck with root line (was + crashing on null input since lexer changes over the past week + or so). + +Thu Apr 13 16:48:30 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * com.c (ffecom_init_0): Register built-in functions for cos, + sin, and sqrt. + (ffecom_tree_fun_type_double): New variable. + (ffecom_expr_intrinsic_): Update f2c input and output files + to latest version of f2c (no important g77-related changes + noted, just bug fixes to f2c and such). + (builtin_function): New function from c-decl.c. + + * com-rt.def: Refer to built-in functions for cos, sin, and sqrt. + +Thu Apr 13 10:25:09 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * com.c (ffecom_expr_intrinsic_): Convert 0. to appropriate + type to keep DCMPLX(I) from crashing the compiler. + (ffecom_expr_): Don't convert result from ffecom_tree_divide_. + (ffecom_tree_divide_): Add tree_type argument, have all callers + pass one, and don't convert right-hand operand to it (this is + to make this new function work as much like the old in-line + code used in ffecom_expr_ as possible). + + * lex.c: Maintain lineno and input_filename the way the gcc + lexer does. + + * std.c (ffestd_exec_end): Save and restore lineno and + input_filename around the second pass, which sets them + appropriately for each saved statement. + +Wed Apr 12 09:44:45 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * com.c (ffecom_expr_power_integer_): New function. + (ffecom_expr_): Call new function for power op with integer second + argument, for generating better code. Also replace divide + code with call to new ffecom_tree_divide_ function. + Canonicalize calls to ffecom_truth_value(_invert). + (ffecom_tree_divide_): New function. + +Wed Apr 5 14:15:44 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * lex.c: Change to allocate text for tokens only when actually + needed, which should speed compilation up somewhat. + Change to allow INCLUDE at any point where a statement + can end, i.e. in ffelex_finish_statement_ or when a SEMICOLON + token is sent. + Remove some old, obsolete code. + Clean up layout of entire file to improve formatting, + readability, etc. + (ffelex_set_expecting_hollerith): Remove include argument. + +Fri Mar 31 23:19:08 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * bad.h, bad.c (ffebad_start_msg, ffebad_start_msg_lex): + New functions to generate arbitrary messages. + (FFEBAD_severityPEDANTIC): New severity, to correspond + to toplev's pedwarn() function. + + * lex.c (ffelex_backslash_): New function to implement + backslash processing. + (ffelex_file_fixed, ffelex_file_free): Implement new + backslash processing. + + * std.c (ffestd_R1001dump_): Don't assume CHARACTER and + HOLLERITH tokens stop at '\0' characters, now that backslash + processing is supported -- use their advertised lengths instead, + and double up the '\002' character for libf2c. + +Mon Mar 27 17:10:33 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * com.c (ffecom_init_local_zero_): Implement -finit-local-zero. + (ffecom_sym_transform_): Same. + (ffecom_transform_equiv_): Same. + + * options-lang.h: Add -f(no-)(init-local-zero,backslash,ugly-init). + + * stb.c (ffestb_V020): Reject "TYPEblah(...", which might be + an array assignment. + + * target.h, top.h, top.c: Implement -finit-local-zero. + +Fri Mar 24 19:56:22 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Make-lang.in, Makefile.in: Remove conf-proj(.in) and + proj.h(.in) rules, plus related config.log, config.cache, + and config.status stuff. + + * com.c (ffecom_init_0): Change messages when atof(), bsearch(), + or strtoul() do not work as expected in the start-up test. + + * conf-proj, conf-proj.in: Delete. + + * lex.c (ffelex_file_fixed): Allow f2c's '&' in column 1 + to mean continuation line. + + * options-lang.h: New file, #include'd by ../toplev.c. + + * proj.h.in: Rename back to proj.h. + + * proj.h (LAME_ASSERT): Remove. + (LAME_STDIO): Remove. + (NO_STDDEF): Remove. + (NO_STDLIB): Remove. + (NO_BSEARCH): Remove auto detection, rename to !FFEPROJ_BSEARCH. + (NO_STRTOUL): Remove auto detection, rename to !FFEPROJ_STRTOUL. + (USE_HOST_LIMITS): Remove (maybe still needed by stand-alone?). + (STR, STRX): Do only ANSI C definitions. + +Mon Mar 13 10:46:13 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * BUGS: Add item about g77 requiring gcc to compile it. + + * NEWS: New file listing user-visible changes in the release. + + * PROJECTS: Update to include a new item or two, and modify + or delete items that are addressed in this or previous releases. + + * bad.c (ffebad_finish): Don't crash if missing string &c, + just substitute obviously distressed string "[REPORT BUG!!]" + for cases where the message/caller are fudgy. + + * bad.def: Clean up error messages in a major way, add new ones + for use by changes in target.c. + + * com.c (ffecom_expr_): Handle opANY in opCONVERT. + (ffecom_let_char_): Disregard destinations with ERROR_MARK. + (ffecom_1, ffecom_1_fn, ffecom_2, ffecom_2s, ffecom_3, + ffecom_3s, &c): Check all inputs for error_mark_node. + (ffecom_start_progunit_): Don't transform all symbols + in BLOCK DATA, since it never executes, and it is silly + to, e.g., generate all the structures for NAMELIST. + (ffecom_char_length_expr_): Rename to ffecom_intrinsic_len_. + (ffecom_intrinsic_ichar_): New function to handle ICHAR of + arbitrary expression with possible 0-length operands. + (ffecom_expr_intrinsic_): Use ffecom_intrinsic_char_. + For MVBITS, set tree_type to void_type_node. + (ffecom_start_progunit_): Name master function for entry points + after primary entry point so users can easily guess it while + debugging. + (ffecom_arg_ptr_to_expr): Change treatment of Hollerith, + Typeless, and %DESCR. + (ffecom_expr_): Change treatment of Hollerith. + + * data.c (ffedata_gather_): Handle opANY in opCONVERT. + + * expr.c (ffeexpr_token_apostrophe_): Issue FFEBAD_NULL_CHAR_CONST + warning as necessary. + (ffeexpr_token_name_rhs_): Set context for args to intrinsic + so that assignment-like concatenation is allowed for ICHAR(), + IACHAR(), and LEN() intrinsics. + (ffeexpr_reduced_*_): Say "an array" instead of "an entity" in + diagnostics, since it's more informative. + (ffeexpr_finished_): For many contexts, check for null expression + and array before trying to do a conversion, to avoid redundant + diagnostics. + + * g77.1: Fix typo for preprocessed suffix (.F, not .f). + + * global.c (ffeglobal_init_common): Warn if initializing + blank common. + (ffeglobal_pad_common): Enable code to warn if initial + padding needed. + (ffeglobal_size_common): Complain if enlarging already- + initialized common, since it won't work right anyway. + + * intrin.c: Add IMAG() intrinsic. + (ffeintrin_check_loc_): Allow opSUBSTR in LOC(). + + * intrin.def: Add IMAG() intrinsic. + + * lex.c: Don't report FFEBAD_NULL_CHAR_CONST errors. + + * sta.c, sta.h, stb.c: Changes to clean up error messages (see + bad.def). + + * stb.c (ffestb_R100113_): Issue FFEBAD_NULL_CHAR_CONST + warning as necessary. + + * stc.c (ffestc_shriek_do_): Don't try to reference doref_line + stuff in ANY case, since it won't be valid. + (ffestc_R1227): Allow RETURN in main program unit, with + appropriate warnings/errors. + (ffestc_subr_format_): Array of any type is a CHAREXPR (F77 C5). + + * ste.c (ffeste_begin_doiter_): Couple of fixes to accurately + determine if loop never executes. + + * target.c (ffetarget_convert_*_hollerith_): Append spaces, + not zeros, to follow F77 Appendix C, and to warn when + truncation of non-blanks done. + (ffetarget_convert_*_typeless): Rewrite to do typeless + conversions properly, and warn when truncation done. + (ffetarget_print_binary, ffetarget_print_octal, + ffetarget_print_hex): Rewrite to use new implementation of + typeless. + (ffetarget_typeless_*): Rewrite to use new implementation + of typeless, and to warn about overflow. + + * target.h (ffetargetTypeless): New implementation of + this type. + + * type.h, type.c (ffetype_size_typeless): Remove (incorrect) + implementation of this function and its extern. + +Sun Mar 5 18:46:42 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * BUGS: Clarify that constant handling would also fix lack of + adequate IEEE-754/854 support to some degree, and typeless + and non-decimal constants. + + * com.c (ffecom_type_permanent_copy_): Comment out to avoid + warnings. + (duplicate_decls): New function a la gcc/c-decl.c. + (pushdecl): Use duplicate_decls to decide whether to return + existing decl or new one, instead of always returning existing + decl. + (ffecom_expr_): opPERCENT_LOC now supports CHARACTER arguments. + (ffecom_init_0): Give f2c I/O code 0 for basictypeANY/kindtypeANY. + (ffecom_sym_transform_): For adjustable arrays, pass low bound + through variable_size in case its primaries are changed (950302-1.f). + + * com.h: More decls that belong in tree.h &c. + + * data.c (ffedata_eval_integer1_): Fix opPAREN case to not + treat value of expression as an error code. + + * expr.c (ffeexpr_finished_): Allow opSUBSTR in contextLOC case. + + * proj.c: Add "const" as appropriate. + +Mon Feb 27 10:04:03 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * bad.def (FFEBAD_BAD_SUBSTR): Fix bad grammar in message. + +Fri Feb 24 16:21:31 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.13 released. + + * INSTALL: Warn that f/zzz.o will compare differently between + stages, since it puts the __TIME__ macro into a string. + + * com.c (ffecom_sym_transform_): Transform kindFUNCTION/whereDUMMY + to pointer-to-function, not function. + (ffecom_expr_): Use ffecom_arg_ptr_to_expr instead of + ffecom_char_args_ to handle comparison between CHARACTER + types, so either operand can be a CONCATENATE. + (ffecom_transform_common_): Set size of initialized common area + to global (largest-known) size, even though size of init might + be smaller. + + * equiv.c (ffeequiv_offset_): Check symbol info for ANY. + + * expr.c (ffeexpr_find_close_paren_, ffeexpr_nil_*): New functions + to handle following the contour of a rejected expression, so + statements like "PRINT(I,I,I)=0" don't cause the PRINT statement + code to get the second passed back to it as if there was a + missing close-paren before it, the comma causing the PRINT code + to confirm the statement, resulting in an ambiguity vis-a-vis + the let statement code. + Use the new ffecom_find_close_paren_ handler when an expected + close-paren is missing. + (ffeexpr_isdigits_): New function, use in all places that + currently use isdigit in repetitive code. + (ffeexpr_collapse_symter): Collapse to ANY if init-expr is ANY, + so as to avoid having symbol get "transformed" if used to + dimension an array. + (ffeexpr_token_real_, ffeexpr_token_number_real_): Don't issue + diagnostic about exponent, since it'll be passed along the + handler path, resulting in a diagnostic anyway. + (ffeexpr_token_apos_char_): Use consistent handler path + regardless of whether diagnostics inhibited. + (ffeexpr_token_name_apos_name_): Skip past closing quote/apos + even if not a match or other diagnostic issued. + (ffeexpr_sym_impdoitem_): Exec-transition local SEEN symbol. + + * lex.c (ffelex_image_char_): Set ffelex_saw_tab_ if TAB + seen, not if anything other than TAB seen! + + * stc.c (ffestc_R537_item): If source is ANY but dest isn't, + set dest symbol's init expr to ANY. + (ffestc_R501_attrib, ffestc_R522, ffestc_R522start): Complain + about conflict between "SAVE" by itself and other uses of + SAVE only in pedantic mode. + + * ste.c (ffeste_R1212): Fix loop over labels to always + increment caseno, to avoid pushcase returning 2 for duplicate + values when one of the labels is invalid. + +Thu Feb 23 12:42:04 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.12 released. + + * Make-lang.in (f77.install-common): Add "else true;" before outer + "fi" per Makefile.in patch. + + * Makefile.in (dircheck): Add "else true;" before "fi" per + patch from chs1pm@surrey.ac.uk. + + * com.c (ffecom_push_tempvar): If type desired is ERROR_MARK, + return error_mark_node, to avoid crash that results from + making a VAR_DECL with error_mark_node as its type. + + * ste.c (ffeste_begin_iterdo_): Convert itercount to INTEGER + anytime calculation of number of iterations ends up with type + other than INTEGER (e.g. DOUBLE PRECISION, REAL). + +Thu Feb 23 02:48:38 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.11 released. + + * DOC: Explain -fugly-args. + + * bad.def (FFEBAD_ACTUALARG): Explain -fugly-args and how to + rewrite code to not require it. + + * com.c (ffecom_vardesc_): Handle negative type code, just in + case. + (ffecom_arg_ptr_to_expr): Let ffecom_expr handle hollerith + and typeless constants (move code to ffecom_constantunion). + (ffecom_constantunion): Handle hollerith and typeless constants. + + * expr.c (ffecom_finished_): Check -fugly-args in actual-arg + context where hollerith/typeless provided. + + * intrin.def (FFEINTRIN_genDFLOAT): Add FFEINTRIN_specDFLOAT. + (FFEINTRIN_specDFLOAT): Add as f2c intrinsic. + + * target.h (ffetarget_convert_real[12]_integer, + ffetarget_convert_complex[12]_integer): Pass -1 for high integer + value if low part is negative. + (FFETARGET_defaultIS_UGLY_ARGS): New macro. + + * top.c (ffe_is_ugly_args_): New variable. + (ffe_decode_option): Handle -fugly-args and -fno-ugly-args. + + * top.h (ffe_is_ugly_args_, ffe_is_ugly_args(), + ffe_set_is_ugly_args()): New variable and macros. + +Thu Feb 23 02:48:38 1995 Pedro A M Vazquez (vazquez@iqm.unicamp.br) + + * g77.c (sys_errlist): Use const for __FreeBSD__ systems + as well. + +Wed Feb 22 13:33:43 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.10 released. + + * CREDITS: Add Rick Niles. + + * INSTALL: Note how to get around lack of makeinfo. + + * Make-lang.in (f/proj.h): Remove # comment. + + * Makefile.in (f/proj.h): Remove # comment. + + * com.c (ffecom_expr_): Simplify opFUNCREF/opSUBRREF conversion. + (ffecom_sym_transform_): For whereGLOBAL and whereDUMMY + kindFUNCTION, use ffecom_tree_fun_type[][] only for non-constant + (non-statement-function) f2c functions. + (ffecom_init_0): ffecom_tree_fun_type[][] and _ptr_to_*_* are + really f2c-interface arrays, so use base type void for COMPLEX + (like CHARACTER). + +Tue Feb 21 19:01:18 1995 Dave Love + + * Make-lang.in (f77.install-common): Expurgate the test for and + possible installation of f2c in line with elsewhere. Seems to have + been missing a semicolon anyhow! + +Tue Feb 21 11:45:25 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.9 released. + + * Make-lang.in (f/proj.h): touch file to register update, + because the previous commands won't necessarily modify it. + + * Makefile.in (f/proj.h): touch file to register update, + because the previous commands won't necessarily modify it. + + * Makefile.in (f/str-*.h, f/str-*.j): Explicitly specify + output file names, so these targets go in build, not source, + directory. + + * bits.c, bits.h: Switch to valid ANSI C replacement for + ARRAY_ZERO. + + * com.c (ffecom_expr_): Add assignp arg to support ASSIGN better. + If assignp is TRUE, use different tree for FFEBLD_opSYMTER case. + (ffecom_sym_transform_assign_): New function. + (ffecom_expr_assign): New function. + (ffecom_expr_assign_w): New function. + + * com.c (ffecom_f2c_make_type_): Do make_signed_type instead + of make_unsigned_type throughout. + + * com.c (ffecom_finish_symbol_transform_): Expand scope of + commented-out code to probably produce faster compiler code. + + * com.c (ffecom_gen_sfuncdef_): Push/pop calltemps so + COMPLEX works right. + Remove obsolete comment. + + * com.c (ffecom_start_progunit_): If non-multi alt-entry + COMPLEX function, primary (static) entry point returns result + directory, not via extra arg -- to agree with ffecom_return_expr + and others. + Pretransform all symbols so statement functions are defined + before any code emitted. + + * com.c (ffecom_finish_progunit): Don't posttransform all + symbols here -- pretransform them instead. + + * com.c (ffecom_init_0): Don't warn about possible ASSIGN + crash, as this shouldn't happen now. + + * com.c (ffecom_push_tempvar): Fix to handle temp vars + pushed while context is a statement (nested) function, and + add appropriate commentary. + + * com.c (ffecom_return_expr): Check TREE_USED to determine + where return value is unset. + + * com.h (struct _ffecom_symbol_): Add note about length_tree + now being used to keep tree for ASSIGN version of symbol. + + * com.h (ffecom_expr_assign, ffecom_expr_assign_rw): New decls. + (error): Add this prototype for back-end function. + + * fini.c (main): Grab input, output, and include names + directly off the command line instead of making the latter + two out of the first. + + * lex.c: Improve tab handling for both fixed and free source + forms, and ignore carriage-returns on input, while generally + improving the code. ffelex_handle_tab_ has been renamed and + reinvented as ffelex_image_char_, among other things. + + * malloc.c, malloc.h: Switch to valid ANSI C replacement for + ARRAY_ZERO, and kill the full number of bytes in pools and + areas. + + * proj.h.in (ARRAY_ZERO, ARRAY_ZERO_SIZE): Remove. + + * ste.c (ffeste_io_cilist_, ffeste_io_icilist_, ffeste_R838, + ffeste_R839): Issue diagnostic if a too-narrow variable used in an + ASSIGN context despite changes to this code and code in com.c. + + * where.c, where.h: Switch to valid ANSI C replacement for + ARRAY_ZERO. + +Fri Feb 17 03:35:19 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.8 released. + + * INSTALL: In quick-build case, list g77 target first so g77 + gets installed. Also, explain that gcc gets built and installed + as well, even though this isn't really what we want (and maybe + we'll find a way around this someday). + +Fri Feb 17 02:35:41 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.7 released. + + * Makefile.in (CONFIG_H, HCONFIG_H, TCONFIG_H, TM_H): Remove + ../ prefix in front of .h files, since they're in the cd. + +Fri Feb 17 01:50:48 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.6 released. + +Thu Feb 16 20:26:54 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * ../README.g77: Remove description of g77 as "not-yet-published". + + * CREDITS: More changes. + + * Make-lang.in (G77STAGESTUFF): Remove cktyps stuff. + + * Makefile.in (CONFIG_H, HCONFIG_H, TCONFIG_H, TM_H): Don't + prefix gcc dir with $(srcdir) since these don't live there, + they are created in the build dir by gcc's configure. Add + a note explaining what these macros are about. + Update dependencies via deps-kinda. + + * README.NEXTSTEP: Credit Toon, and per his request, add his + email address. + + * com.h (FFECOM_DETERMINE_TYPES): #include "config.j". + + * config.j, convert.j, flags.j, hconfig.j, rtl.j, tconfig.j, + tm.j, tree.j: Don't #include if already done. + + * convert.j: #include "tree.j" first, as convert.h clearly depends + on trees being defined. + + * rtl.j: #include "config.j" first, since there's some stuff + in rtl.h that assumes it has been #included. + + * tree.j: #include "config.j" first, or real.h makes inconsistent + decision about return type of ereal_atof, leading to bugs, and + because tree.h/real.h assume config.h already included. + +Wed Feb 15 14:40:20 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.5 released. + + * Copyright notices updated to be FSF-style. + + * INSTALL: Some more clarification regarding building just f77. + + * Make-lang.in (F77_SRCS): Update wrt changing some .h to .j. + (install-libf77): Fix typo in new parenthetical note. + + * Makefile.in (f/*.o): Update. + (CONFIG_H, CONVERT_H, FLAGS_H, GLIMITS_H, HCONFIG_H, RTL_H, + TCONFIG_H, TM_H, TREE_H): Update/new symbols. + (deps-kinda): More fixes wrt changing some .h to .j. + Document and explain this rule a bit better. + Accommodate changes in output of gcc -MM. + + * *.h, *.c: Change #include's so proj.h not assumed to #include + malloc.h or config.h (now config.j), and so new .j files are + used instead of old .h ones. + + * com.c (ffecom_init_0): Use FLOAT_TYPE_SIZE for f2c's + TYLONG/TYLOGICAL type codes, to get g77 working on Alpha. + + * com.h: Make all f2c-related integral types "int", not "long + int". + + * config.j, convert.j, flags.j, glimits.j, hconfig.j, rtl.j, + tconfig.j, tm.j, tree.j: New files wrapping around gbe + .h files. + + * config.h, convert.h, flags.h, glimits.h, hconfig.h, rtl.h, + tconfig.h, tm.h, tree.h: Deleted so new .j files + can #include the gbe files directly, instead of using "../", + and thus do better with various kinds of builds. + + * proj.h: Delete unused NO_STDDEF and related stuff. + +Tue Feb 14 08:28:08 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * BUGS: Remove item #12, cross-compiling & autoconf scripts + reportedly expected to work properly (according to d.love). + + * INSTALL: Add explanation of d.love's patch to config-lang.in. + Add explanation of how to install just g77 when gcc already installed. + Add note about usability of "-Wall". Add note about bug- + reporting. + + * Make-lang.in ($(srcdir)/f/conf-proj): Add comment about why + conf-proj.out. + (install-libf77): Echo parenthetical note to user about how to do + just the (aborted) libf2c installation. + (deps-kinda): Update to work with new configuration/build stuff. + + * bad.c (ffebad_finish): Put capitalized "warning:" &c message + as prefix on any diagnostic without pointers into source. + + * bad.def (FFEBAD_TOO_BIG_INIT): Add this warning message. + + * config-lang.in: Add Dave Love's patch to catch case where + back-end patches not applied and abort configuration. + + * data.c (ffedata_gather_, ffedata_value_): Warn when about + to initialize a large aggregate area, due to design flaw resulting + in too much time/space used to handle such cases. + Use COMMON area name, and first notice of symbol, for multiple- + initialization diagnostic, instead of member symbol and unknown + location. + (FFEDATA_sizeTOO_BIG_INIT_): New macro per above. + +Mon Feb 13 13:54:26 1995 Dave Love + + * Make-lang.in (F77_SRCS): Use $(srcdir)/f/proj.h.in, not + $(srcdir)/f/proj.h for build outside srcdir. + +Sun Feb 12 13:37:11 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * ../README.g77: Clarify procedures for unpacking, add asterisks + to mark important things the user must do. + + * Fix dates in/add dates to ../README.g77, BUGS, CREDITS, DOC, + INSTALL, PROJECTS, README. + +Sun Feb 12 00:26:10 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.4 released. + + * Make-lang.in (f/proj.h): Reproduce this rule here from + Makefile.in. + ($(srcdir)/f/conf-proj): Put autoconf's stdout in temp file + conf-proj.out, then mv to conf-proj only if successful, so + conf-proj not touched if autoconf not installed. + + * Makefile.in ($(srcdir)/conf-proj): See Make-lang.in's similar + rule. + +Sat Feb 11 20:56:02 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * BUGS: Clarify some bugs. + + * DOC: Many improvements and fixes. + + * README: Move bulk of text, edited, to ../README.g77, and + replace with pointer to that file. + + * com.c (ffecom_init_0): Comment out warning about sizeof(ftnlen) + as per ste.c change. Add text about ASSIGN to help user understand + what is being warned about. + + * conf-proj.in: Fix typos in comments. + + * proj.h.in: Add ARRAY_ZERO_SIZE to parallel malloc.h's version, + in case it proves to be needed. + + * ste.c: Comment out assertions requiring sizeof(ftnlen) >= + sizeof(char *), in the hopes that overflow will never happen. + (ffeste_R838): Change assertion to fatal() with at least + partially helpful message. + +Sat Feb 11 12:38:00 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * com.c (ffecom_vardesc_): Crash if typecode is -1. + + * ste.c (ffeste_io_dolio_): Crash if typecode is -1. + +Sat Feb 11 09:51:57 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * ste.c: In I/O code tests for item arrayness, sort of revert + to much earlier code that tests original exp, but also check + in newer way just in case. Newer way alone treated FOO(1:40) + as an array, not sure why older way alone didn't work, but I + think maybe it was when diagnosed code was involved, and + since there are now checks for error_mark_node, maybe the old + way alone would work. But better to be safe; both original + ffebld exp _and_ the transformed tree must indicate an array + for the size-determination code to be used, else just 1/2 elements + assumed. And this text is for EMACS: (foo at bar). + +Fri Feb 10 11:05:50 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * ste.c: In many cases, surround statement-expansion code + with ffecom_push_calltemps () and ffecom_pop_calltemps () + so COMPLEX-returning functions can have temporaries pushed + in "auto-pop" mode and have them auto-popped at the end of + the statement. + +Wed Feb 8 14:35:10 1995 Dave Love + + * runtime/f2c.h.in (ftnlen, ftnint): Make same size as integer. + + * runtime/libI77/err.c (f_init): Thinko in MISSING_FILE_ELEMS + conditional. + * runtime/libI77/wrtfmt.c (mv_cur): Likewise. + * runtime/libI77/wsfe.c (x_putc): Likewise. + + * runtime/libF77/signal_.c (signal_): Return 0 (this is a + subroutine). + + * Makefile.in (f/proj.h): Depend on com.h. + * Make-lang.in (include/f2c.h): Likewise (and proj.h). + (install-libf77): Also install f2c.h. + + * runtime/libI77/Makefile.in (*.o): Add f2c.h dependency. + * runtime/libF77/Makefile.in: Likewise. + +Wed Feb 8 13:56:47 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * stc.c (ffestc_R501_item): Don't reset kind/where to NONE when + setting basictype/kindtype info for symbol, or especially + its function/result twin, because kind/where might not be NONE. + +Tue Feb 7 14:47:26 1995 Dave Love + + * Make-lang.in (include/f2c.h:): Set shell variable src more + robustly (independent of whether srcdir is relative or absolute). + * Makefile.in (f/proj.h:): Likewise. + + * conf-proj.in: Check need for LAME_ASSERT. Fix indentation in + check for LAME_STDIO (cosmetic only with ANSI C). + + * com.h: Extra ...SIZE stuff taken from com.c. + + * com.c (FFECOM_DETERMINE_TYPES): Define before including com.h. + (BITS_PER_WORD etc.) Remove and use conditional definitions to com.h. + + * runtime/configure.in: #define FFECOM_DETERMINE_TYPES for com.h in + f2c type determination. + + * tm.h: Remove (at least pro tem) because of relative path and use + top-level one. + + * Make-lang.in (include/f2c.h:): Set shell variable src more + robustly (independent of whether srcdir is relative or absolute). + * Makefile.in (f/proj.h:): Likewise. + +Mon Feb 6 19:58:32 1995 Dave Love + + * g77.c (append_arg): Use K&R declaration for, e.g. SunOS4 build. + +Fri Feb 3 20:33:14 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * g77.c (main): Treat -l like filename in terms of -x handling. + Rewrite arglist mechanism for ease of maintenance. + Make sure every -lf2c is followed by -lm and vice versa. + + * Make-lang.in: Put complete list of sources in F77_SRCS def + so changing a .h file, for example, causes rebuild. + + * Makefile.in: Change test for nextstep to m68k-next-nextstep* so + all versions of nextstep on m68k get the necessary flag. + +Fri Feb 3 19:10:32 1995 Dave Love + + * INSTALL: Note about possible conflict with existing libf2c.a and + f2c.h. + + * Make-lang.in (f77.distclean): Tidy and move deletion of + f/config.cache to mostlyclean. + (install-libf77): Test for $(libdir)/libf2c.* and barf if found + unless F2CLIBOK defined. + + * runtime/Makefile.in (all): Change path to include directory (and + elsewhere). + (INCLUDES): Remove (unused/misleading). + (distclean): Include f2c.h. + (clean): Include config.cache. + + * runtime/libF77/Makefile.in (.SUFFIXES): Correct typo. + (ALL_CFLAGS) Fix up include search path to find f2c.h in top level + includes always. + (all): Depend on f2c.h. + * runtime/libI77/Makefile.in (.SUFFIXES): Likewise. + +Thu Feb 2 17:17:06 1995 Dave Love + + * INSTALL: Note about --srcdir and GNU make. + + * runtime/f2c.h.in (Pad_UDread, ALWAYS_FLUSH): Reomve the #defines + per below. + + * runtime/configure.in (Pad_UDread, ALWAYS_FLUSH): Define these + here, not in f2c.h as they'r eonly relevant for building. + * runtime/configure: Regenerated. + + * config-lang.in: Warn about using GNU make outside source tree + since I can't get Irix5 or SunOS4 makes to work in this case. + + * Makefile.in (VPATH): Don't set it here. + (srcdir): Make it the normal `.' (overridden) at top level. + (all.indirect): New dependency `dircheck'. + (f771): Likewise + (dircheck): New target for foolproofing. + (f/proj.h:): Change finding source. + (CONFIG_H): Don't use this as the relative path in the include loses + f builddir != srcdir. + + * config.h: Remove per CONFIG_H change above. + + * Make-lang.in (F77_FLAGS_TO_PASS): Remove GCC_FOR_TARGET. + (f771:): Pass VPATH, srcdir to sub-make. + (f/Makefile:): New target. + (stmp-int-hdrs): new variable for cheating build. + (f77-runtime:): Alter GCC_FOR_TARGET treatment. + (include/f2c.h f/runtime/Makefile:) Likewise. + (f77-runtime-unsafe:): New (cheating) target. + +Thu Feb 2 12:09:51 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * BUGS: Update regarding losing EQUIVALENCE members in -g, and + regarding RS/6000 problems in the back end. + + * CREDITS: Make some changes as requested. + + * com.c (ffecom_member_trunk_): Remove unused static variable. + (ffecom_finish_symbol_transform_): Improve comments. + (ffecom_let_char_): Fix size of temp address-type var. + (ffecom_member_phase2_): Try fixing problem fixed by change + to ffecom_transform_equiv_ (f_m_p2_ function currently not used). + (ffecom_transform_equiv_): Remove def of unused static variable. + Comment-out use of ffecom_member_phase2_, until problems with + back end fixed. + (ffecom_push_tempvar): Fix assertion to not crash okay code. + + * com.h: Remove old, commented-out code. + Add prototype for warning() in back end. + + * ste.c (ffeste_io_dofio_, ffeste_io_dolio_, ffeste_io_douio_, + ffeste_io_icilist_): Check correct type of variable for arrayness. + +Sun Jan 29 14:41:42 1995 Dave Love + + * BUGS: Remove references to my configure bugs; add another. + + * runtime/Makefile.in (AR_FLAGS): Provide default value. + + * runtime/f2c.h.in (integer, logical): Take typedefs from + F2C_INTEGER configuration parameter again. + (NON_UNIX_STDIO): don't define it. + + * runtime/configure.in: Bring type checks for f2c.h in line with + com.h. + (MISSING_FILE_ELEMS): New variable to determine whether the relevant + elements of the FILE struct exist, independent of NON_UNIX_STDIO. + * runtime/libI77/{err,wrtfmt,wsfe}.c (MISSING_FILE_ELEMS): Use new + parameter. + + * config-lang.in: Comment out more of f2c rules (c.f. Make-lang.in). + (This stuff is relevant iff you gave configure --enable-f2c.) + Create f/runtime directory tree iff not building in source + directory. + + * Makefile.in (srcdir): Append slash so we get the right value when + not building in the source directory. This is a consequence of not + building the `f' sources in `f'. + (VPATH): Override configure's value for reasons above. + (f/proj.h f/conf-proj): New rules to build proj.h by + autoconfiguration. + + * proj.h: Rename to proj.h.in for autoconfiguration. + * proj.h.in: New as above. + * conf-proj conf-proj.in: New files for autoconfiguration. + + * Make-lang.in (include/f2c.h f/runtime/Makefile:): Change the order + of setting the sh variables so that the right GCC_FOR_TARGET is + used. + (f77.*clean:) Add products of new configuration files and make sure + all the *clean targets do something (unlike the ones in + cp/Make-lange.in). + + * com.h (FFECOM_f2cINTEGER, FFECOM_f2cLOGICAL): Define as long or + int appropriately to ensure sizeof(real) == sizeof(integer). + + * PROJECTS: Library section. + + * runtime/libI77/endfile.c: Don't #include sys/types.h conditional + on NON_UNIX_STDIO since rawio.h needs size_t. + * runtime/libI77/uio.c: #include for size_t if not + KR_headers. + +Wed Jan 25 03:31:51 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.3 released. + + * INSTALL: Revise. + + * Make-lang.in: Comment out rules for building f2c itself (f/f2c/). + + * README: Revise. + + * com.c (ffecom_init_0): Warn if ftnlen or INTEGER not big enough + to hold a char *. + + * gbe/2.6.2.diff: Update. + +Mon Jan 23 17:10:49 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * TODO: Remove. + BUGS: New file. + PROJECTS: New file. + CREDITS: New file. + + * cktyps*: Remove. + Make-lang.in: Remove cktyps stuff. + Makefile.in: Remove cktyps stuff. + + * DOC: Add info on changes for 0.5.3. + + * bad.c: Put "warning:" &c on diagnostic messages. + Don't output informational messages if warnings disabled. + +Thu Jan 19 12:38:13 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * g77.c: Avoid putting out useless "-xnone -xf77" pairs so + larger command lines can be accommodated. + Recognize both `-xlang' and `-x lang'. + Recognize `-xnone' and `-x none' to mean what it does, instead + of treating "none" as any other language. + Some minor, slight improvements in the way args are handled + (hopefully for clearer, more maintainable code), including + consistency checks on arg count just in case. + +Wed Jan 18 16:41:57 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * DOC: Explain -fautomatic better. + + * INSTALL: Describe libf2c.a better. + + * Make-lang.in, Makefile.in: Build f771 &c with gcc/ as cd instead + of gcc/f/ so debugging info is better (source file tracking). + Add new source file type.c. + + * Makefile.in: For nextstep3, link f771 with -segaddr __DATA + 6000000. Fix typo. Change deps-kinda target to handle building + from gcc/. Update dependencies. + + * bld-op.def, bld.h, bld.c: Remove opBACKEND and all related + stuff. + Remove consistency tests that cause compiler warnings. + + * cktyps.c: Remove all typing checking. + + * com-rt.def: Change all rttypeFLOAT_ intrinsics to rttypeDOUBLE_, + to precisely match how they're declared in libf2c. + + * com.h, com.c: Revise to more elegantly track related stuff + in the version of f2c.h used to build libf2c. + + * com.c: Increase FFECOM_sizeMAXSTACKITEM, and if 0 or undefined + when checked to determine where to put entity, treat as infinite. + Rewrite temporary mechanism to be based on trees instead of + ffeinfo stuff, and make it much simpler. Change interface + accordingly. + Fixes to better track types of things, make appropriate + conversions, etc. E.g. when making an arg for a libf2c + function, make sure it's of the right type (such as ftnlen). + Delete opBACKEND transformation code. + (ffecom_init_0): Smoother initialization of types, especially + paying attention to using consistent rules for making INTEGER, + REAL, DOUBLE PRECISION, etc., and for deciding their "*N" + and kind values that will work across all g77 platforms. + No longer require per-target configuration info in target.h + or config/*/*; use new type module to store size, alignment. + (ffecom_member_phase2): Declare COMMON/EQUIVALENCE group members + so debugger sees them. + (ffecom_finish_progunit): Transform all symbols in program unit, + so -g will show they all exist. + + * expr.c (ffeexpr_collapse_substr): Handle strange substring + range values. + + * info.h, info.c: Provide connection to new type module. + Remove tests that yield compiler warnings. + + * intrin.c (ffeintrin_is_intrinsic): Properly handle deleted + intrinsic. + + * lex.c (ffelex_file_fixed): Remove redundant/buggy code. + + * stc.c (ffestc_kindtype_kind_, ffestc_kindtype_star_): Replace + boring switch stmt with simple call to new type module. This + sort of thing is a reason to get up in the morning. + + * ste.c: Update to handle new interface for + ffecom_push/pop_tempvar. + Fixes to better track types of things. + Fixes to not crash for certain diagnosed constructs. + (ffeste_begin_iterdo_): Check only constants for overflow to avoid + spurious diagnostics. + Don't convert larger integer (say, INTEGER*8) to canonical integer + for iteration count. + + * stw.h: Track DO iteration count temporary variable. + + * symbol.c: Remove consistency tests that cause compiler warnings. + + * target.c (ffetarget_aggregate_info): Replace big switch with + little call to new type module. + (ffetarget_layout): Remove consistency tests that cause + compiler warnings. + (ffetarget_convert_character1_typeless): Pick up length of + typeless type from new type module. + + * target.h: Crash build if target float bit pattern cannot be + precisely determined. + Remove all the type cruft now determined by ffecom_init_0 + at invocation time and maintained in new type module. + Put casts on second arg of all REAL_VALUE_TO_TARGET_DOUBLE + uses so compiler warnings avoided (requires target float bit + pattern to be precisely determined, hence code to crash build). + + * top.c: Add inits/terminates for new type module. + + * type.h, type.c: New module. + + * gbe/2.6.2.diff: Remove all patches to files in gcc/config/ + directory and its subdirectories. + +Mon Jan 9 19:23:25 1995 Dave Love + + * com.h (FFECOM_F2C_INTEGER_TYPE_NODE): Define and use instead of + long_integer_type_node where appropriate. + +Tue Jan 3 14:56:18 1995 Dave Love + + * com.h: Make ffecom_f2c_logical_type_node long, consistent with + integer. + +Fri Dec 2 20:07:37 1994 Dave Love + + * config-lang.in (stagestuff): Add f2c conditionally. + * Make-lang.in: Add f2c and related targets. + * f2c: Add the directory. + +Fri Nov 25 22:17:26 1994 Dave Love + + * Makefile.in (FLAGS_TO_PASS): pass $(CROSS) + * Make-lang.in: more changes to runtime targets + +Thu Nov 24 18:03:21 1994 Dave Love + + * Makefile.in (FLAGS_TO_PASS): define for sub-makes + + * g77.c (main): change f77-cpp-output to f77-cpp-input (.F files) + +Wed Nov 23 15:22:53 1994 Dave Love + + * bad.c (ffebad_finish): kluge to fool emacs19 into finding errors: + add trailing space to :: + +Tue Nov 22 11:30:50 1994 Dave Love + + * runtime/libF77/signal_.c (RETSIGTYPE): added + +Mon Nov 21 13:04:13 1994 Dave Love + + * Makefile.in (compiler): add runtime + + * config-lang.in (stagestuff): add libf2c.a to stagestuff + + * Make-lang.in: + G77STAGESTUFF <- MORESTAGESTUFF + f77-runtime: new target, plus supporting ones + + * runtime: add the directory, containing libI77, libF77 and autoconf + stuff + + * g++.1: remove + + * g77.1: minor fixes + +Thu Nov 17 15:18:05 1994 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.2 released. + + * bad.def: Modify wording of FFEBAD_UNIMPL_STMT to indicate + that it covers a wide array of possible problems (that, someday, + should be handled via separate diagnostics). + + * lex.c: Allow $ in identifiers if -fdollar-ok. + * top.c: Support -fdollar-ok. + * top.h: Support -fdollar-ok. + * target.h: Support -fdollar-ok. + * DOC: Describe -fdollar-ok. + + * std.c (ffestd_R1229_finish): Fix bug so stand-alone build works. + * ste.c (ffeste_R819A): Fix bug so stand-alone build works. + + * Make: Improvements for stand-alone build. + + * Makefile.in: Fix copyright text at top of file. + + * LINK, SRCS, UNLINK: Removed. Not particularly useful now that + g77 sources live in their own subdirectory. + + * g77.c (main): Cast arg to bzero to avoid warning. (This is + identical to Kenner's fix to cp/g++.c.) + + * gbe/: New subdirectory, to contain .diff files for various + versions of the GNU CC back end. + + * gbe/README: New file. + * gbe/2.6.2.diff: New file. + +Tue Nov 8 10:23:10 1994 Dave Love + + * Make-lang.in: don't install as f77 as well as g77 to avoid + confusion with system's compiler (especially while testing) + + * g77.c (main): use -lf2c and -lm; fix sense of test for .f/.F files + +Fri Oct 28 09:45:00 1994 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.1 released. + + * gcc.c: Invoke f771 instead of f-771. + +Fri Oct 28 02:00:44 1994 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.0 released. + +Fri Oct 14 15:03:35 1994 Craig Burley (burley@gnu.ai.mit.edu) + + * Makefile.in: Handle the Fortran-77 front-end in a subdirectory. + * f-*: Move Fortran-77 front-end to f/*. diff --git a/gcc/f/INSTALL b/gcc/f/INSTALL new file mode 100644 index 000000000000..97423be14980 --- /dev/null +++ b/gcc/f/INSTALL @@ -0,0 +1,1517 @@ +This file contains installation information for the GNU Fortran +compiler. Copyright (C) 1995, 1996 Free Software Foundation, Inc. You +may copy, distribute, and modify it freely as long as you preserve this +copyright notice and permission notice. + +Installing GNU Fortran +********************** + + The following information describes how to install `g77'. + + The information in this file generally pertains to dealing with +*source* distributions of `g77' and `gcc'. It is possible that some of +this information will be applicable to some *binary* distributions of +these products--however, since these distributions are not made by the +maintainers of `g77', responsibility for binary distributions rests with +whoever built and first distributed them. + + Nevertheless, efforts to make `g77' easier to both build and install +from source and package up as a binary distribution are ongoing. + +Prerequisites +============= + + The procedures described to unpack, configure, build, and install +`g77' assume your system has certain programs already installed. + + The following prerequisites should be met by your system before you +follow the `g77' installation instructions: + +`gzip' + To unpack the `gcc' and `g77' distributions, you'll need the + `gunzip' utility in the `gzip' distribution. Most UNIX systems + already have `gzip' installed. If yours doesn't, you can get it + from the FSF. + + Note that you'll need `tar' and other utilities as well, but all + UNIX systems have these. There are GNU versions of all these + available--in fact, a complete GNU UNIX system can be put together + on most systems, if desired. + +`gcc-2.7.2.2.tar.gz' + You need to have this, or some other applicable, version of `gcc' + on your system. The version should be an exact copy of a + distribution from the FSF. It is approximately 7MB large. + + If you've already unpacked `gcc-2.7.2.2.tar.gz' into a directory + (named `gcc-2.7.2.2') called the "source tree" for `gcc', you can + delete the distribution itself, but you'll need to remember to + skip any instructions to unpack this distribution. + + Without an applicable `gcc' source tree, you cannot build `g77'. + You can obtain an FSF distribution of `gcc' from the FSF. + +`g77-0.5.21.tar.gz' + You probably have already unpacked this distribution, or you are + reading an advanced copy of this manual, which is contained in + this distribution. This distribution approximately 1MB large. + + You can obtain an FSF distribution of `g77' from the FSF, the same + way you obtained `gcc'. + +100MB disk space + For a complete "bootstrap" build, about 100MB of disk space is + required for `g77' by the author's current GNU/Linux system. + + Some juggling can reduce the amount of space needed; during the + bootstrap process, once Stage 3 starts, during which the version + of `gcc' that has been copied into the `stage2/' directory is used + to rebuild the system, you can delete the `stage1/' directory to + free up some space. + + It is likely that many systems don't require the complete + bootstrap build, as they already have a recent version of `gcc' + installed. Such systems might be able to build `g77' with only + about 75MB of free space. + +`patch' + Although you can do everything `patch' does yourself, by hand, + without much trouble, having `patch' installed makes installation + of new versions of GNU utilities such as `g77' so much easier that + it is worth getting. You can obtain `patch' the same way you + obtained `gcc' and `g77'. + + In any case, you can apply patches by hand--patch files are + designed for humans to read them. + +`make' + Your system must have `make', and you will probably save yourself + a lot of trouble if it is GNU `make' (sometimes referred to as + `gmake'). + +`cc' + Your system must have a working C compiler. + + *Note Installing GNU CC: (gcc)Installation, for more information + on prerequisites for installing `gcc'. + +`bison' + If you do not have `bison' installed, you can usually work around + any need for it, since `g77' itself does not use it, and `gcc' + normally includes all files generated by running it in its + distribution. You can obtain `bison' the same way you obtained + `gcc' and `g77'. + + *Note Missing bison?::, for information on how to work around not + having `bison'. + +`makeinfo' + If you are missing `makeinfo', you can usually work around any + need for it. You can obtain `makeinfo' the same way you obtained + `gcc' and `g77'. + + *Note Missing makeinfo?::, for information on getting around the + lack of `makeinfo'. + +`root' access + To perform the complete installation procedures on a system, you + need to have `root' access to that system, or equivalent access. + + Portions of the procedure (such as configuring and building `g77') + can be performed by any user with enough disk space and virtual + memory. + + However, these instructions are oriented towards less-experienced + users who want to install `g77' on their own personal systems. + + System administrators with more experience will want to determine + for themselves how they want to modify the procedures described + below to suit the needs of their installation. + +Problems Installing +=================== + + This is a list of problems (and some apparent problems which don't +really mean anything is wrong) that show up when configuring, building, +installing, or porting GNU Fortran. + + *Note Installation Problems: (gcc)Installation Problems, for more +information on installation problems that can afflict either `gcc' or +`g77'. + +General Problems +---------------- + + These problems can occur on most or all systems. + +GNU C Required +.............. + + Compiling `g77' requires GNU C, not just ANSI C. Fixing this +wouldn't be very hard (just tedious), but the code using GNU extensions +to the C language is expected to be rewritten for 0.6 anyway, so there +are no plans for an interim fix. + + This requirement does not mean you must already have `gcc' installed +to build `g77'. As long as you have a working C compiler, you can use a +bootstrap build to automate the process of first building `gcc' using +the working C compiler you have, then building `g77' and rebuilding +`gcc' using that just-built `gcc', and so on. + +Patching GNU CC Necessary +......................... + + `g77' currently requires application of a patch file to the gcc +compiler tree. The necessary patches should be folded in to the +mainline gcc distribution. + + Some combinations of versions of `g77' and `gcc' might actually +*require* no patches, but the patch files will be provided anyway as +long as there are more changes expected in subsequent releases. These +patch files might contain unnecessary, but possibly helpful, patches. +As a result, it is possible this issue might never be resolved, except +by eliminating the need for the person configuring `g77' to apply a +patch by hand, by going to a more automated approach (such as +configure-time patching). + +Building GNU CC Necessary +......................... + + It should be possible to build the runtime without building `cc1' +and other non-Fortran items, but, for now, an easy way to do that is +not yet established. + +Missing strtoul +............... + + On SunOS4 systems, linking the `f771' program produces an error +message concerning an undefined symbol named `_strtoul'. + + This is not a `g77' bug. *Note Patching GNU Fortran::, for +information on a workaround provided by `g77'. + + The proper fix is either to upgrade your system to one that provides +a complete ANSI C environment, or improve `gcc' so that it provides one +for all the languages and configurations it supports. + + *Note:* In earlier versions of `g77', an automated workaround for +this problem was attempted. It worked for systems without `_strtoul', +substituting the incomplete-yet-sufficient version supplied with `g77' +for those systems. However, the automated workaround failed +mysteriously for systems that appeared to have conforming ANSI C +environments, and it was decided that, lacking resources to more fully +investigate the problem, it was better to not punish users of those +systems either by requiring them to work around the problem by hand or +by always substituting an incomplete `strtoul()' implementation when +their systems had a complete, working one. Unfortunately, this meant +inconveniencing users of systems not having `strtoul()', but they're +using obsolete (and generally unsupported) systems anyway. + +Object File Differences +....................... + + A comparison of object files after building Stage 3 during a +bootstrap build will result in `gcc/f/zzz.o' being flagged as different +from the Stage 2 version. That is because it contains a string with an +expansion of the `__TIME__' macro, which expands to the current time of +day. It is nothing to worry about, since `gcc/f/zzz.c' doesn't contain +any actual code. It does allow you to override its use of `__DATE__' +and `__TIME__' by defining macros for the compilation--see the source +code for details. + +Cleanup Kills Stage Directories +............................... + + It'd be helpful if `g77''s `Makefile.in' or `Make-lang.in' would +create the various `stageN' directories and their subdirectories, so +developers and expert installers wouldn't have to reconfigure after +cleaning up. + +Missing `gperf'? +................ + + If a build aborts trying to invoke `gperf', that strongly suggests +an improper method was used to create the `gcc' source directory, such +as the UNIX `cp -r' command instead of `cp -pr', since this problem +very likely indicates that the date-time-modified information on the +`gcc' source files is incorrect. + + The proper solution is to recreate the `gcc' source directory from a +`gcc' distribution known to be provided by the FSF. + + It is possible you might be able to temporarily work around the +problem, however, by trying these commands: + + sh# cd gcc + sh# touch c-gperf.h + sh# + + These commands update the date-time-modified information for the +file produced by the invocation of `gperf' in the current versions of +`gcc', so that `make' no longer believes it needs to update it. This +file should already exist in a `gcc' distribution, but mistakes made +when copying the `gcc' directory can leave the modification information +set such that the `gperf' input files look more "recent" than the +corresponding output files. + + If the above does not work, definitely start from scratch and avoid +copying the `gcc' using any method that does not reliably preserve +date-time-modified information, such as the UNIX `cp -r' command. + +Cross-compiler Problems +----------------------- + + `g77' has been in alpha testing since September of 1992, and in +public beta testing since February of 1995. Alpha testing was done by +a small number of people worldwide on a fairly wide variety of +machines, involving self-compilation in most or all cases. Beta +testing has been done primarily via self-compilation, but in more and +more cases, cross-compilation (and "criss-cross compilation", where a +version of a compiler is built on one machine to run on a second and +generate code that runs on a third) has been tried and has succeeded, +to varying extents. + + Generally, `g77' can be ported to any configuration to which `gcc', +`f2c', and `libf2c' can be ported and made to work together, aside from +the known problems described in this manual. If you want to port `g77' +to a particular configuration, you should first make sure `gcc' and +`libf2c' can be ported to that configuration before focusing on `g77', +because `g77' is so dependent on them. + + Even for cases where `gcc' and `libf2c' work, you might run into +problems with cross-compilation on certain machines, for several +reasons. + + * There is one known bug (a design bug to be fixed in 0.6) that + prevents configuration of `g77' as a cross-compiler in some cases, + though there are assumptions made during configuration that + probably make doing non-self-hosting builds a hassle, requiring + manual intervention. + + * `gcc' might still have some trouble being configured for certain + combinations of machines. For example, it might not know how to + handle floating-point constants. + + * Improvements to the way `libf2c' is built could make building + `g77' as a cross-compiler easier--for example, passing and using + `LD' and `AR' in the appropriate ways. + + * There are still some challenges putting together the right + run-time libraries (needed by `libf2c') for a target system, + depending on the systems involved in the configuration. (This is + a general problem with cross-compilation, and with `gcc' in + particular.) + +Changing Settings Before Building +================================= + + Here are some internal `g77' settings that can be changed by editing +source files in `gcc/f/' before building. + + This information, and perhaps even these settings, represent +stop-gap solutions to problems people doing various ports of `g77' have +encountered. As such, none of the following information is expected to +be pertinent in future versions of `g77'. + +Larger File Unit Numbers +------------------------ + + As distributed, whether as part of `f2c' or `g77', `libf2c' accepts +file unit numbers only in the range 0 through 99. For example, a +statement such as `WRITE (UNIT=100)' causes a run-time crash in +`libf2c', because the unit number, 100, is out of range. + + If you know that Fortran programs at your installation require the +use of unit numbers higher than 99, you can change the value of the +`MXUNIT' macro, which represents the maximum unit number, to an +appropriately higher value. + + To do this, edit the file `f/runtime/libI77/fio.h' in your `g77' +source tree, changing the following line: + + #define MXUNIT 100 + + Change the line so that the value of `MXUNIT' is defined to be at +least one *greater* than the maximum unit number used by the Fortran +programs on your system. + + (For example, a program that does `WRITE (UNIT=255)' would require +`MXUNIT' set to at least 256 to avoid crashing.) + + Then build or rebuild `g77' as appropriate. + + *Note:* Changing this macro has *no* effect on other limits your +system might place on the number of files open at the same time. That +is, the macro might allow a program to do `WRITE (UNIT=100)', but the +library and operating system underlying `libf2c' might disallow it if +many other files have already been opened (via `OPEN' or implicitly via +`READ', `WRITE', and so on). Information on how to increase these +other limits should be found in your system's documentation. + +Always Flush Output +------------------- + + Some Fortran programs require output (writes) to be flushed to the +operating system (under UNIX, via the `fflush()' library call) so that +errors, such as disk full, are immediately flagged via the relevant +`ERR=' and `IOSTAT=' mechanism, instead of such errors being flagged +later as subsequent writes occur, forcing the previously written data +to disk, or when the file is closed. + + Essentially, the difference can be viewed as synchronous error +reporting (immediate flagging of errors during writes) versus +asynchronous, or, more precisely, buffered error reporting (detection +of errors might be delayed). + + `libf2c' supports flagging write errors immediately when it is built +with the `ALWAYS_FLUSH' macro defined. This results in a `libf2c' that +runs slower, sometimes quite a bit slower, under certain +circumstances--for example, accessing files via the networked file +system NFS--but the effect can be more reliable, robust file I/O. + + If you know that Fortran programs requiring this level of precision +of error reporting are to be compiled using the version of `g77' you +are building, you might wish to modify the `g77' source tree so that +the version of `libf2c' is built with the `ALWAYS_FLUSH' macro defined, +enabling this behavior. + + To do this, find this line in `f/runtime/configure.in' in your `g77' +source tree: + + dnl AC_DEFINE(ALWAYS_FLUSH) + + Remove the leading `dnl ', so the line begins with `AC_DEFINE(', and +run `autoconf' in that file's directory. (Or, if you don't have +`autoconf', you can modify `f2c.h.in' in the same directory to include +the line `#define ALWAYS_FLUSH' after `#define F2C_INCLUDE'.) + + Then build or rebuild `g77' as appropriate. + +Maximum Stackable Size +---------------------- + + `g77', on most machines, puts many variables and arrays on the stack +where possible, and can be configured (by changing +`FFECOM_sizeMAXSTACKITEM' in `gcc/f/com.c') to force smaller-sized +entities into static storage (saving on stack space) or permit +larger-sized entities to be put on the stack (which can improve +run-time performance, as it presents more opportunities for the GBE to +optimize the generated code). + + *Note:* Putting more variables and arrays on the stack might cause +problems due to system-dependent limits on stack size. Also, the value +of `FFECOM_sizeMAXSTACKITEM' has no effect on automatic variables and +arrays. *Note But-bugs::, for more information. + +Floating-point Bit Patterns +--------------------------- + + The `g77' build will crash if an attempt is made to build it as a +cross-compiler for a target when `g77' cannot reliably determine the +bit pattern of floating-point constants for the target. Planned +improvements for g77-0.6 will give it the capabilities it needs to not +have to crash the build but rather generate correct code for the target. +(Currently, `g77' would generate bad code under such circumstances if +it didn't crash during the build, e.g. when compiling a source file +that does something like `EQUIVALENCE (I,R)' and `DATA R/9.43578/'.) + +Initialization of Large Aggregate Areas +--------------------------------------- + + A warning message is issued when `g77' sees code that provides +initial values (e.g. via `DATA') to an aggregate area (`COMMON' or +`EQUIVALENCE', or even a large enough array or `CHARACTER' variable) +that is large enough to increase `g77''s compile time by roughly a +factor of 10. + + This size currently is quite small, since `g77' currently has a +known bug requiring too much memory and time to handle such cases. In +`gcc/f/data.c', the macro `FFEDATA_sizeTOO_BIG_INIT_' is defined to the +minimum size for the warning to appear. The size is specified in +storage units, which can be bytes, words, or whatever, on a +case-by-case basis. + + After changing this macro definition, you must (of course) rebuild +and reinstall `g77' for the change to take effect. + + Note that, as of version 0.5.18, improvements have reduced the scope +of the problem for *sparse* initialization of large arrays, especially +those with large, contiguous uninitialized areas. However, the warning +is issued at a point prior to when `g77' knows whether the +initialization is sparse, and delaying the warning could mean it is +produced too late to be helpful. + + Therefore, the macro definition should not be adjusted to reflect +sparse cases. Instead, adjust it to generate the warning when densely +initialized arrays begin to cause responses noticeably slower than +linear performance would suggest. + +Alpha Problems Fixed +-------------------- + + `g77' used to warn when it was used to compile Fortran code for a +target configuration that is not basically a 32-bit machine (such as an +Alpha, which is a 64-bit machine, especially if it has a 64-bit +operating system running on it). That was because `g77' was known to +not work properly on such configurations. + + As of version 0.5.20, `g77' is believed to work well enough on such +systems. So, the warning is no longer needed or provided. + + However, support for 64-bit systems, especially in areas such as +cross-compilation and handling of intrinsics, is still incomplete. The +symptoms are believed to be compile-time diagnostics rather than the +generation of bad code. It is hoped that version 0.6 will completely +support 64-bit systems. + +Quick Start +=========== + + This procedure configures, builds, and installs `g77' "out of the +box" and works on most UNIX systems. Each command is identified by a +unique number, used in the explanatory text that follows. For the most +part, the output of each command is not shown, though indications of +the types of responses are given in a few cases. + + To perform this procedure, the installer must be logged in as user +`root'. Much of it can be done while not logged in as `root', and +users experienced with UNIX administration should be able to modify the +procedure properly to do so. + + Following traditional UNIX conventions, it is assumed that the +source trees for `g77' and `gcc' will be placed in `/usr/src'. It also +is assumed that the source distributions themselves already reside in +`/usr/FSF', a naming convention used by the author of `g77' on his own +system: + + /usr/FSF/gcc-2.7.2.2.tar.gz + /usr/FSF/g77-0.5.21.tar.gz + + Users of the following systems should not blindly follow these +quick-start instructions, because of problems their systems have coping +with straightforward installation of `g77': + + * SunOS4 + + Instead, see *Note Complete Installation::, for detailed information +on how to configure, build, and install `g77' for your particular +system. Also, see *Note Known Causes of Trouble with GNU Fortran: +Trouble, for information on bugs and other problems known to afflict the +installation process, and how to report newly discovered ones. + + If your system is *not* on the above list, and *is* a UNIX system or +one of its variants, you should be able to follow the instructions +below. If you vary *any* of the steps below, you might run into +trouble, including possibly breaking existing programs for other users +of your system. Before doing so, it is wise to review the explanations +of some of the steps. These explanations follow this list of steps. + + sh[ 1]# cd /usr/src + + sh[ 2]# gunzip -c < /usr/FSF/gcc-2.7.2.2.tar.gz | tar xf - + [Might say "Broken pipe"...that is normal on some systems.] + + sh[ 3]# gunzip -c < /usr/FSF/g77-0.5.21.tar.gz | tar xf - + ["Broken pipe" again possible.] + + sh[ 4]# ln -s gcc-2.7.2.2 gcc + + sh[ 5]# ln -s g77-0.5.21 g77 + + sh[ 6]# mv -i g77/* gcc + [No questions should be asked by mv here; or, you made a mistake.] + + sh[ 7]# patch -p1 -V t -d gcc < gcc/f/gbe/2.7.2.2.diff + [Unless patch complains about rejected patches, this step worked.] + + sh[ 8]# cd gcc + sh[ 9]# touch f77-install-ok + [Do not do the above if your system already has an f77 + command, unless you've checked that overwriting it + is okay.] + + sh[10]# touch f2c-install-ok + [Do not do the above if your system already has an f2c + command, unless you've checked that overwriting it + is okay. Else, touch f2c-exists-ok.] + + sh[11]# ./configure --prefix=/usr + [Do not do the above if gcc is not installed in /usr/bin. + You might need a different --prefix=..., as + described below.] + + sh[12]# make bootstrap + [This takes a long time, and is where most problems occur.] + + sh[13]# rm -fr stage1 + + sh[14]# make -k install + [The actual installation.] + + sh[15]# g77 -v + [Verify that g77 is installed, obtain version info.] + + sh[16]# + + *Note Updating Your Info Directory: Updating Documentation, for +information on how to update your system's top-level `info' directory +to contain a reference to this manual, so that users of `g77' can +easily find documentation instead of having to ask you for it. + + Elaborations of many of the above steps follows: + +Step 1: `cd /usr/src' + You can build `g77' pretty much anyplace. By convention, this + manual assumes `/usr/src'. It might be helpful if other users on + your system knew where to look for the source code for the + installed version of `g77' and `gcc' in any case. + +Step 3: `gunzip -d < /usr/FSF/g77-0.5.21.tar.gz | tar xf -' + It is not always necessary to obtain the latest version of `g77' + as a complete `.tar.gz' file if you have a complete, earlier + distribution of `g77'. If appropriate, you can unpack that earlier + version of `g77', and then apply the appropriate patches to + achieve the same result--a source tree containing version 0.5.21 + of `g77'. + +Step 4: `ln -s gcc-2.7.2.2 gcc' + +Step 5: `ln -s g77-0.5.21 g77' + These commands mainly help reduce typing, and help reduce visual + clutter in examples in this manual showing what to type to install + `g77'. + + *Note Unpacking::, for information on using distributions of `g77' + made by organizations other than the FSF. + +Step 6: `mv -i g77/* gcc' + After doing this, you can, if you like, type `rm g77' and `rmdir + g77-0.5.21' to remove the empty directory and the symbol link to + it. But, it might be helpful to leave them around as quick + reminders of which version(s) of `g77' are installed on your + system. + + *Note Unpacking::, for information on the contents of the `g77' + directory (as merged into the `gcc' directory). + +Step 7: `patch -p1 ...' + This can produce a wide variety of printed output, from `Hmm, I + can't seem to find a patch in there anywhere...' to long lists of + messages indicated that patches are being found, applied + successfully, and so on. + + If messages about "fuzz", "offset", or especially "reject files" + are printed, it might mean you applied the wrong patch file. If + you believe this is the case, it is best to restart the sequence + after deleting (or at least renaming to unused names) the + top-level directories for `g77' and `gcc' and their symbolic links. + + After this command finishes, the `gcc' directory might have old + versions of several files as saved by `patch'. To remove these, + after `cd gcc', type `rm -i *.~*~'. + + *Note Merging Distributions::, for more information. + +Step 9: `touch f77-install-ok' + Don't do this if you don't want to overwrite an existing version + of `f77' (such as a native compiler, or a script that invokes + `f2c'). Otherwise, installation will overwrite the `f77' command + and the `f77' man pages with copies of the corresponding `g77' + material. + + *Note Installing `f77': Installing f77, for more information. + +Step 10: `touch f2c-install-ok' + Don't do this if you don't want to overwrite an existing + installation of `libf2c' (though, chances are, you do). Instead, + `touch f2c-exists-ok' to allow the installation to continue + without any error messages about `/usr/lib/libf2c.a' already + existing. + + *Note Installing `f2c': Installing f2c, for more information. + +Step 11: `./configure --prefix=/usr' + This is where you specify that the `g77' executable is to be + installed in `/usr/bin/', the `libf2c.a' library is to be + installed in `/usr/lib/', and so on. + + You should ensure that any existing installation of the `gcc' + executable is in `/usr/bin/'. Otherwise, installing `g77' so that + it does not fully replace the existing installation of `gcc' is + likely to result in the inability to compile Fortran programs. + + *Note Where in the World Does Fortran (and GNU CC) Go?: Where to + Install, for more information on determining where to install + `g77'. *Note Configuring gcc::, for more information on the + configuration process triggered by invoking the `./configure' + script. + +Step 12: `make bootstrap' + *Note Installing GNU CC: (gcc)Installation, for information on the + kinds of diagnostics you should expect during this procedure. + + *Note Building gcc::, for complete `g77'-specific information on + this step. + +Step 13: `rm -fr stage1' + You don't need to do this, but it frees up disk space. + +Step 14: `make -k install' + If this doesn't seem to work, try: + + make -k install install-libf77 install-f2c-all + + *Note Installation of Binaries::, for more information. + + *Note Updating Your Info Directory: Updating Documentation, for + information on entering this manual into your system's list of + texinfo manuals. + +Step 15: `g77 -v' + If this command prints approximately 25 lines of output, including + the GNU Fortran Front End version number (which should be the same + as the version number for the version of `g77' you just built and + installed) and the version numbers for the three parts of the + `libf2c' library (`libF77', `libI77', `libU77'), and those version + numbers are all in agreement, then there is a high likelihood that + the installation has been successfully completed. + + You might consider doing further testing. For example, log in as + a non-privileged user, then create a small Fortran program, such + as: + + PROGRAM SMTEST + DO 10 I=1, 10 + PRINT *, 'Hello World #', I + 10 CONTINUE + END + + Compile, link, and run the above program, and, assuming you named + the source file `smtest.f', the session should look like this: + + sh# g77 -o smtest smtest.f + sh# ./smtest + Hello World # 1 + Hello World # 2 + Hello World # 3 + Hello World # 4 + Hello World # 5 + Hello World # 6 + Hello World # 7 + Hello World # 8 + Hello World # 9 + Hello World # 10 + sh# + + After proper installation, you don't need to keep your gcc and g77 + source and build directories around anymore. Removing them can + free up a lot of disk space. + +Complete Installation +===================== + + Here is the complete `g77'-specific information on how to configure, +build, and install `g77'. + +Unpacking +--------- + + The `gcc' source distribution is a stand-alone distribution. It is +designed to be unpacked (producing the `gcc' source tree) and built as +is, assuming certain prerequisites are met (including the availability +of compatible UNIX programs such as `make', `cc', and so on). + + However, before building `gcc', you will want to unpack and merge +the `g77' distribution in with it, so that you build a Fortran-capable +version of `gcc', which includes the `g77' command, the necessary +run-time libraries, and this manual. + + Unlike `gcc', the `g77' source distribution is *not* a stand-alone +distribution. It is designed to be unpacked and, afterwards, +immediately merged into an applicable `gcc' source tree. That is, the +`g77' distribution *augments* a `gcc' distribution--without `gcc', +generally only the documentation is immediately usable. + + A sequence of commands typically used to unpack `gcc' and `g77' is: + + sh# cd /usr/src + sh# gunzip -d < /usr/FSF/gcc-2.7.2.2.tar.gz | tar xf - + sh# gunzip -d < /usr/FSF/g77-0.5.21.tar.gz | tar xf - + sh# ln -s gcc-2.7.2.2 gcc + sh# ln -s g77-0.5.21 g77 + sh# mv -i g77/* gcc + + *Notes:* The commands beginning with `gunzip...' might print `Broken +pipe...' as they complete. That is nothing to worry about, unless you +actually *hear* a pipe breaking. The `ln' commands are helpful in +reducing typing and clutter in installation examples in this manual. +Hereafter, the top level of `gcc' source tree is referred to as `gcc', +and the top level of just the `g77' source tree (prior to issuing the +`mv' command, above) is referred to as `g77'. + + There are three top-level names in a `g77' distribution: + + g77/COPYING.g77 + g77/README.g77 + g77/f + + All three entries should be moved (or copied) into a `gcc' source +tree (typically named after its version number and as it appears in the +FSF distributions--e.g. `gcc-2.7.2.2'). + + `g77/f' is the subdirectory containing all of the code, +documentation, and other information that is specific to `g77'. The +other two files exist to provide information on `g77' to someone +encountering a `gcc' source tree with `g77' already present, who has +not yet read these installation instructions and thus needs help +understanding that the source tree they are looking at does not come +from a single FSF distribution. They also help people encountering an +unmerged `g77' source tree for the first time. + + *Note:* Please use *only* `gcc' and `g77' source trees as +distributed by the FSF. Use of modified versions, such as the +Pentium-specific-optimization port of `gcc', is likely to result in +problems that appear to be in the `g77' code but, in fact, are not. Do +not use such modified versions unless you understand all the +differences between them and the versions the FSF distributes--in which +case you should be able to modify the `g77' (or `gcc') source trees +appropriately so `g77' and `gcc' can coexist as they do in the stock +FSF distributions. + +Merging Distributions +--------------------- + + After merging the `g77' source tree into the `gcc' source tree, the +final merge step is done by applying the pertinent patches the `g77' +distribution provides for the `gcc' source tree. + + Read the file `gcc/f/gbe/README', and apply the appropriate patch +file for the version of the GNU CC compiler you have, if that exists. +If the directory exists but the appropriate file does not exist, you +are using either an old, unsupported version, or a release one that is +newer than the newest `gcc' version supported by the version of `g77' +you have. + + As of version 0.5.18, `g77' modifies the version number of `gcc' via +the pertinent patches. This is done because the resulting version of +`gcc' is deemed sufficiently different from the vanilla distribution to +make it worthwhile to present, to the user, information signaling the +fact that there are some differences. + + GNU version numbers make it easy to figure out whether a particular +version of a distribution is newer or older than some other version of +that distribution. The format is, generally, MAJOR.MINOR.PATCH, with +each field being a decimal number. (You can safely ignore leading +zeros; for example, 1.5.3 is the same as 1.5.03.) The MAJOR field only +increases with time. The other two fields are reset to 0 when the +field to their left is incremented; otherwise, they, too, only increase +with time. So, version 2.6.2 is newer than version 2.5.8, and version +3.0 is newer than both. (Trailing `.0' fields often are omitted in +announcements and in names for distributions and the directories they +create.) + + If your version of `gcc' is older than the oldest version supported +by `g77' (as casually determined by listing the contents of +`gcc/f/gbe/'), you should obtain a newer, supported version of `gcc'. +(You could instead obtain an older version of `g77', or try and get +your `g77' to work with the old `gcc', but neither approach is +recommended, and you shouldn't bother reporting any bugs you find if you +take either approach, because they're probably already fixed in the +newer versions you're not using.) + + If your version of `gcc' is newer than the newest version supported +by `g77', it is possible that your `g77' will work with it anyway. If +the version number for `gcc' differs only in the PATCH field, you might +as well try applying the `g77' patch that is for the newest version of +`gcc' having the same MAJOR and MINOR fields, as this is likely to work. + + So, for example, if a particular version of `g77' has support for +`gcc' versions 2.7.0 and 2.7.1, it is likely that `gcc-2.7.2' would +work well with `g77' by using the `2.7.1.diff' patch file provided with +`g77' (aside from some offsets reported by `patch', which usually are +harmless). + + However, `gcc-2.8.0' would almost certainly not work with that +version of `g77' no matter which patch file was used, so a new version +of `g77' would be needed (and you should wait for it rather than +bothering the maintainers--*note User-Visible Changes: Changes.). + + This complexity is the result of `gcc' and `g77' being separate +distributions. By keeping them separate, each product is able to be +independently improved and distributed to its user base more frequently. + + However, `g77' often requires changes to contemporary versions of +`gcc'. Also, the GBE interface defined by `gcc' typically undergoes +some incompatible changes at least every time the MINOR field of the +version number is incremented, and such changes require corresponding +changes to the `g77' front end (FFE). + + It is hoped that the GBE interface, and the `gcc' and `g77' products +in general, will stabilize sufficiently for the need for hand-patching +to disappear. + + Invoking `patch' as described in `gcc/f/gbe/README' can produce a +wide variety of printed output, from `Hmm, I can't seem to find a patch +in there anywhere...' to long lists of messages indicated that patches +are being found, applied successfully, and so on. + + If messages about "fuzz", "offset", or especially "reject files" are +printed, it might mean you applied the wrong patch file. If you +believe this is the case, it is best to restart the sequence after +deleting (or at least renaming to unused names) the top-level +directories for `g77' and `gcc' and their symbolic links. That is +because `patch' might have partially patched some `gcc' source files, +so reapplying the correct patch file might result in the correct +patches being applied incorrectly (due to the way `patch' necessarily +works). + + After `patch' finishes, the `gcc' directory might have old versions +of several files as saved by `patch'. To remove these, after `cd gcc', +type `rm -i *.~*~'. + + *Note:* `g77''s configuration file `gcc/f/config-lang.in' ensures +that the source code for the version of `gcc' being configured has at +least one indication of being patched as required specifically by `g77'. +This configuration-time checking should catch failure to apply the +correct patch and, if so caught, should abort the configuration with an +explanation. *Please* do not try to disable the check, otherwise `g77' +might well appear to build and install correctly, and even appear to +compile correctly, but could easily produce broken code. + + `diff -rcp2N' is used to create the patch files in `gcc/f/gbe/'. + +Installing `f77' +---------------- + + You should decide whether you want installation of `g77' to also +install an `f77' command. On systems with a native `f77', this is not +normally desired, so `g77' does not do this by default. + + If you want `f77' installed, create the file `f77-install-ok' (e.g. +via the UNIX command `touch f77-install-ok') in the source or build +top-level directory (the same directory in which the `g77' `f' +directory resides, not the `f' directory itself), or edit +`gcc/f/Make-lang.in' and change the definition of the +`F77_INSTALL_FLAG' macro appropriately. + + Usually, this means that, after typing `cd gcc', you would type +`touch f77-install-ok'. + + When you enable installation of `f77', either a link to or a direct +copy of the `g77' command is made. Similarly, `f77.1' is installed as +a man page. + + (The `uninstall' target in the `gcc/Makefile' also tests this macro +and file, when invoked, to determine whether to delete the installed +copies of `f77' and `f77.1'.) + + *Note:* No attempt is yet made to install a program (like a shell +script) that provides compatibility with any other `f77' programs. +Only the most rudimentary invocations of `f77' will work the same way +with `g77'. + +Installing `f2c' +---------------- + + Currently, `g77' does not include `f2c' itself in its distribution. +However, it does include a modified version of the `libf2c'. This +version is normally compatible with `f2c', but has been modified to +meet the needs of `g77' in ways that might possibly be incompatible +with some versions or configurations of `f2c'. + + Decide how installation of `g77' should affect any existing +installation of `f2c' on your system. + + If you do not have `f2c' on your system (e.g. no `/usr/bin/f2c', no +`/usr/include/f2c.h', and no `/usr/lib/libf2c.a', `/usr/lib/libF77.a', +or `/usr/lib/libI77.a'), you don't need to be concerned with this item. + + If you do have `f2c' on your system, you need to decide how users of +`f2c' will be affected by your installing `g77'. Since `g77' is +currently designed to be object-code-compatible with `f2c' (with very +few, clear exceptions), users of `f2c' might want to combine +`f2c'-compiled object files with `g77'-compiled object files in a +single executable. + + To do this, users of `f2c' should use the same copies of `f2c.h' and +`libf2c.a' that `g77' uses (and that get built as part of `g77'). + + If you do nothing here, the `g77' installation process will not +overwrite the `include/f2c.h' and `lib/libf2c.a' files with its own +versions, and in fact will not even install `libf2c.a' for use with the +newly installed versions of `gcc' and `g77' if it sees that +`lib/libf2c.a' exists--instead, it will print an explanatory message +and skip this part of the installation. + + To install `g77''s versions of `f2c.h' and `libf2c.a' in the +appropriate places, create the file `f2c-install-ok' (e.g. via the UNIX +command `touch f2c-install-ok') in the source or build top-level +directory (the same directory in which the `g77' `f' directory resides, +not the `f' directory itself), or edit `gcc/f/Make-lang.in' and change +the definition of the `F2C_INSTALL_FLAG' macro appropriately. + + Usually, this means that, after typing `cd gcc', you would type +`touch f2c-install-ok'. + + Make sure that when you enable the overwriting of `f2c.h' and +`libf2c.a' as used by `f2c', you have a recent and properly configured +version of `bin/f2c' so that it generates code that is compatible with +`g77'. + + If you don't want installation of `g77' to overwrite `f2c''s existing +installation, but you do want `g77' installation to proceed with +installation of its own versions of `f2c.h' and `libf2c.a' in places +where `g77' will pick them up (even when linking `f2c'-compiled object +files--which might lead to incompatibilities), create the file +`f2c-exists-ok' (e.g. via the UNIX command `touch f2c-exists-ok') in +the source or build top-level directory, or edit `gcc/f/Make-lang.in' +and change the definition of the `F2CLIBOK' macro appropriately. + +Patching GNU Fortran +-------------------- + + If you're using a SunOS4 system, you'll need to make the following +change to `gcc/f/proj.h': edit the line reading + + #define FFEPROJ_STRTOUL 1 ... + +by replacing the `1' with `0'. Or, you can avoid editing the source by +adding + CFLAGS='-DFFEPROJ_STRTOUL=0 -g -O' + to the command line for `make' when you invoke it. (`-g' is the +default for `CFLAGS'.) + + This causes a minimal version of `strtoul()' provided as part of the +`g77' distribution to be compiled and linked into whatever `g77' +programs need it, since some systems (like SunOS4 with only the bundled +compiler and its runtime) do not provide this function in their system +libraries. + + Similarly, a minimal version of `bsearch()' is available and can be +enabled by editing a line similar to the one for `strtoul()' above in +`gcc/f/proj.h', if your system libraries lack `bsearch()'. The method +of overriding `X_CFLAGS' may also be used. + + These are not problems with `g77', which requires an ANSI C +environment. You should upgrade your system to one that provides a +full ANSI C environment, or encourage the maintainers of `gcc' to +provide one to all `gcc'-based compilers in future `gcc' distributions. + + *Note Problems Installing::, for more information on why `strtoul()' +comes up missing and on approaches to dealing with this problem that +have already been tried. + +Where in the World Does Fortran (and GNU CC) Go? +------------------------------------------------ + + Before configuring, you should make sure you know where you want the +`g77' and `gcc' binaries to be installed after they're built, because +this information is given to the configuration tool and used during the +build itself. + + A `g77' installation necessarily requires installation of a +`g77'-aware version of `gcc', so that the `gcc' command recognizes +Fortran source files and knows how to compile them. + + For this to work, the version of `gcc' that you will be building as +part of `g77' *must* be installed as the "active" version of `gcc' on +the system. + + Sometimes people make the mistake of installing `gcc' as +`/usr/local/bin/gcc', leaving an older, non-Fortran-aware version in +`/usr/bin/gcc'. (Or, the opposite happens.) This can result in `g77' +being unable to compile Fortran source files, because when it calls on +`gcc' to do the actual compilation, `gcc' complains that it does not +recognize the language, or the file name suffix. + + So, determine whether `gcc' already is installed on your system, +and, if so, *where* it is installed, and prepare to configure the new +version of `gcc' you'll be building so that it installs over the +existing version of `gcc'. + + You might want to back up your existing copy of `bin/gcc', and the +entire `lib/' directory, before you perform the actual installation (as +described in this manual). + + Existing `gcc' installations typically are found in `/usr' or +`/usr/local'. If you aren't certain where the currently installed +version of `gcc' and its related programs reside, look at the output of +this command: + + gcc -v -o /tmp/delete-me -xc /dev/null -xnone + + All sorts of interesting information on the locations of various +`gcc'-related programs and data files should be visible in the output +of the above command. (The output also is likely to include a +diagnostic from the linker, since there's no `main_()' function.) +However, you do have to sift through it yourself; `gcc' currently +provides no easy way to ask it where it is installed and where it looks +for the various programs and data files it calls on to do its work. + + Just *building* `g77' should not overwrite any installed +programs--but, usually, after you build `g77', you will want to install +it, so backing up anything it might overwrite is a good idea. (This is +true for any package, not just `g77', though in this case it is +intentional that `g77' overwrites `gcc' if it is already installed--it +is unusual that the installation process for one distribution +intentionally overwrites a program or file installed by another +distribution.) + + Another reason to back up the existing version first, or make sure +you can restore it easily, is that it might be an older version on +which other users have come to depend for certain behaviors. However, +even the new version of `gcc' you install will offer users the ability +to specify an older version of the actual compilation programs if +desired, and these older versions need not include any `g77' components. +*Note Specifying Target Machine and Compiler Version: (gcc)Target +Options, for information on the `-V' option of `gcc'. + +Configuring GNU CC +------------------ + + `g77' is configured automatically when you configure `gcc'. There +are two parts of `g77' that are configured in two different +ways--`g77', which "camps on" to the `gcc' configuration mechanism, and +`libf2c', which uses a variation of the GNU `autoconf' configuration +system. + + Generally, you shouldn't have to be concerned with either `g77' or +`libf2c' configuration, unless you're configuring `g77' as a +cross-compiler. In this case, the `libf2c' configuration, and possibly +the `g77' and `gcc' configurations as well, might need special +attention. (This also might be the case if you're porting `gcc' to a +whole new system--even if it is just a new operating system on an +existing, supported CPU.) + + To configure the system, see *Note Installing GNU CC: +(gcc)Installation, following the instructions for running `./configure'. +Pay special attention to the `--prefix=' option, which you almost +certainly will need to specify. + + (Note that `gcc' installation information is provided as a straight +text file in `gcc/INSTALL'.) + + The information printed by the invocation of `./configure' should +show that the `f' directory (the Fortran language) has been configured. +If it does not, there is a problem. + + *Note:* Configuring with the `--srcdir' argument is known to work +with GNU `make', but it is not known to work with other variants of +`make'. Irix5.2 and SunOS4.1 versions of `make' definitely won't work +outside the source directory at present. `g77''s portion of the +`configure' script issues a warning message about this when you +configure for building binaries outside the source directory. + +Building GNU CC +--------------- + + Building `g77' requires building enough of `gcc' that these +instructions assume you're going to build all of `gcc', including +`g++', `protoize', and so on. You can save a little time and disk +space by changes the `LANGUAGES' macro definition in `gcc/Makefile.in' +or `gcc/Makefile', but if you do that, you're on your own. One change +is almost *certainly* going to cause failures: removing `c' or `f77' +from the definition of the `LANGUAGES' macro. + + After configuring `gcc', which configures `g77' and `libf2c' +automatically, you're ready to start the actual build by invoking +`make'. + + *Note:* You *must* have run `./configure' before you run `make', +even if you're using an already existing `gcc' development directory, +because `./configure' does the work to recognize that you've added +`g77' to the configuration. + + There are two general approaches to building GNU CC from scratch: + +"bootstrap" + This method uses minimal native system facilities to build a + barebones, unoptimized `gcc', that is then used to compile + ("bootstrap") the entire system. + +"straight" + This method assumes a more complete native system exists, and uses + that just once to build the entire system. + + On all systems without a recent version of `gcc' already installed, +the bootstrap method must be used. In particular, `g77' uses +extensions to the C language offered, apparently, only by `gcc'. + + On most systems with a recent version of `gcc' already installed, +the straight method can be used. This is an advantage, because it +takes less CPU time and disk space for the build. However, it does +require that the system have fairly recent versions of many GNU +programs and other programs, which are not enumerated here. + +Bootstrap Build +............... + + A complete bootstrap build is done by issuing a command beginning +with `make bootstrap ...', as described in *Note Installing GNU CC: +(gcc)Installation. This is the most reliable form of build, but it +does require the most disk space and CPU time, since the complete system +is built twice (in Stages 2 and 3), after an initial build (during +Stage 1) of a minimal `gcc' compiler using the native compiler and +libraries. + + You might have to, or want to, control the way a bootstrap build is +done by entering the `make' commands to build each stage one at a time, +as described in the `gcc' manual. For example, to save time or disk +space, you might want to not bother doing the Stage 3 build, in which +case you are assuming that the `gcc' compiler you have built is +basically sound (because you are giving up the opportunity to compare a +large number of object files to ensure they're identical). + + To save some disk space during installation, after Stage 2 is built, +you can type `rm -fr stage1' to remove the binaries built during Stage +1. + + *Note:* *Note Object File Differences::, for information on expected +differences in object files produced during Stage 2 and Stage 3 of a +bootstrap build. These differences will be encountered as a result of +using the `make compare' or similar command sequence recommended by the +GNU CC installation documentation. + + Also, *Note Installing GNU CC: (gcc)Installation, for important +information on building `gcc' that is not described in this `g77' +manual. For example, explanations of diagnostic messages and whether +they're expected, or indicate trouble, are found there. + +Straight Build +.............. + + If you have a recent version of `gcc' already installed on your +system, and if you're reasonably certain it produces code that is +object-compatible with the version of `gcc' you want to build as part +of building `g77', you can save time and disk space by doing a straight +build. + + To build just the C and Fortran compilers and the necessary run-time +libraries, issue the following command: + + make -k CC=gcc LANGUAGES=f77 all g77 + + (The `g77' target is necessary because the `gcc' build procedures +apparently do not automatically build command drivers for languages in +subdirectories. It's the `all' target that triggers building +everything except, apparently, the `g77' command itself.) + + If you run into problems using this method, you have two options: + + * Abandon this approach and do a bootstrap build. + + * Try to make this approach work by diagnosing the problems you're + running into and retrying. + + Especially if you do the latter, you might consider submitting any +solutions as bug/fix reports. *Note Known Causes of Trouble with GNU +Fortran: Trouble. + + However, understand that many problems preventing a straight build +from working are not `g77' problems, and, in such cases, are not likely +to be addressed in future versions of `g77'. + +Pre-installation Checks +----------------------- + + Before installing the system, which includes installing `gcc', you +might want to do some minimum checking to ensure that some basic things +work. + + Here are some commands you can try, and output typically printed by +them when they work: + + sh# cd /usr/src/gcc + sh# ./g77 --driver=./xgcc -B./ -v + g77 version 0.5.21 + ./xgcc -B./ -v -fnull-version -o /tmp/gfa18047 ... + Reading specs from ./specs + gcc version 2.7.2.2.f.3 + ./cpp -lang-c -v -isystem ./include -undef ... + GNU CPP version 2.7.2.2.f.3 (Linux/Alpha) + #include "..." search starts here: + #include <...> search starts here: + ./include + /usr/local/include + /usr/alpha-unknown-linux/include + /usr/lib/gcc-lib/alpha-unknown-linux/2.7.2.2.f.3/include + /usr/include + End of search list. + ./f771 /tmp/cca18048.i -fset-g77-defaults -quiet -dumpbase ... + GNU F77 version 2.7.2.2.f.3 (Linux/Alpha) compiled ... + GNU Fortran Front End version 0.5.21 compiled: ... + as -nocpp -o /tmp/cca180481.o /tmp/cca18048.s + ld -G 8 -O1 -o /tmp/gfa18047 /usr/lib/crt0.o -L. ... + __G77_LIBF77_VERSION__: 0.5.21 + @(#)LIBF77 VERSION 19970404 + __G77_LIBI77_VERSION__: 0.5.21 + @(#) LIBI77 VERSION pjw,dmg-mods 19970527 + __G77_LIBU77_VERSION__: 0.5.21 + @(#) LIBU77 VERSION 19970609 + sh# ./xgcc -B./ -v -o /tmp/delete-me -xc /dev/null -xnone + Reading specs from ./specs + gcc version 2.7.2.2.f.3 + ./cpp -lang-c -v -isystem ./include -undef ... + GNU CPP version 2.7.2.2.f.3 (Linux/Alpha) + #include "..." search starts here: + #include <...> search starts here: + ./include + /usr/local/include + /usr/alpha-unknown-linux/include + /usr/lib/gcc-lib/alpha-unknown-linux/2.7.2.2.f.3/include + /usr/include + End of search list. + ./cc1 /tmp/cca18063.i -quiet -dumpbase null.c -version ... + GNU C version 2.7.2.2.f.3 (Linux/Alpha) compiled ... + as -nocpp -o /tmp/cca180631.o /tmp/cca18063.s + ld -G 8 -O1 -o /tmp/delete-me /usr/lib/crt0.o -L. ... + /usr/lib/crt0.o: In function `__start': + crt0.S:110: undefined reference to `main' + /usr/lib/crt0.o(.lita+0x28): undefined reference to `main' + sh# + + (Note that long lines have been truncated, and `...' used to +indicate such truncations.) + + The above two commands test whether `g77' and `gcc', respectively, +are able to compile empty (null) source files, whether invocation of +the C preprocessor works, whether libraries can be linked, and so on. + + If the output you get from either of the above two commands is +noticeably different, especially if it is shorter or longer in ways +that do not look consistent with the above sample output, you probably +should not install `gcc' and `g77' until you have investigated further. + + For example, you could try compiling actual applications and seeing +how that works. (You might want to do that anyway, even if the above +tests work.) + + To compile using the not-yet-installed versions of `gcc' and `g77', +use the following commands to invoke them. + + To invoke `g77', type: + + /usr/src/gcc/g77 --driver=/usr/src/gcc/xgcc -B/usr/src/gcc/ ... + + To invoke `gcc', type: + + /usr/src/gcc/xgcc -B/usr/src/gcc/ ... + +Installation of Binaries +------------------------ + + After configuring, building, and testing `g77' and `gcc', when you +are ready to install them on your system, type: + + make -k CC=gcc LANGUAGES=f77 install + + As described in *Note Installing GNU CC: (gcc)Installation, the +values for the `CC' and `LANGUAGES' macros should be the same as those +you supplied for the build itself. + + So, the details of the above command might vary if you used a +bootstrap build (where you might be able to omit both definitions, or +might have to supply the same definitions you used when building the +final stage) or if you deviated from the instructions for a straight +build. + + If the above command does not install `libf2c.a' as expected, try +this: + + make -k ... install install-libf77 install-f2c-all + + We don't know why some non-GNU versions of `make' sometimes require +this alternate command, but they do. (Remember to supply the +appropriate definitions for `CC' and `LANGUAGES' where you see `...' in +the above command.) + + Note that using the `-k' option tells `make' to continue after some +installation problems, like not having `makeinfo' installed on your +system. It might not be necessary for your system. + +Updating Your Info Directory +---------------------------- + + As part of installing `g77', you should make sure users of `info' +can easily access this manual on-line. Do this by making sure a line +such as the following exists in `/usr/info/dir', or in whatever file is +the top-level file in the `info' directory on your system (perhaps +`/usr/local/info/dir': + + * g77: (g77). The GNU Fortran programming language. + + If the menu in `dir' is organized into sections, `g77' probably +belongs in a section with a name such as one of the following: + + * Fortran Programming + + * Writing Programs + + * Programming Languages + + * Languages Other Than C + + * Scientific/Engineering Tools + + * GNU Compilers + +Missing `bison'? +---------------- + + If you cannot install `bison', make sure you have started with a +*fresh* distribution of `gcc', do *not* do `make maintainer-clean' (in +other versions of `gcc', this was called `make realclean'), and, to +ensure that `bison' is not invoked by `make' during the build, type +these commands: + + sh# cd gcc + sh# touch bi-parser.c bi-parser.h c-parse.c c-parse.h cexp.c + sh# touch cp/parse.c cp/parse.h objc-parse.c + sh# + + These commands update the date-time-modified information for all the +files produced by the various invocations of `bison' in the current +versions of `gcc', so that `make' no longer believes it needs to update +them. All of these files should already exist in a `gcc' distribution, +but the application of patches to upgrade to a newer version can leave +the modification information set such that the `bison' input files look +more "recent" than the corresponding output files. + + *Note:* New versions of `gcc' might change the set of files it +generates by invoking `bison'--if you cannot figure out for yourself +how to handle such a situation, try an older version of `gcc' until you +find someone who can (or until you obtain and install `bison'). + +Missing `makeinfo'? +------------------- + + If you cannot install `makeinfo', either use the `-k' option when +invoking make to specify any of the `install' or related targets, or +specify `MAKEINFO=echo' on the `make' command line. + + If you fail to do one of these things, some files, like `libf2c.a', +might not be installed, because the failed attempt by `make' to invoke +`makeinfo' causes it to cancel any further processing. + +Distributing Binaries +===================== + + If you are building `g77' for distribution to others in binary form, +first make sure you are aware of your legal responsibilities (read the +file `gcc/COPYING' thoroughly). + + Then, consider your target audience and decide where `g77' should be +installed. + + For systems like GNU/Linux that have no native Fortran compiler (or +where `g77' could be considered the native compiler for Fortran and +`gcc' for C, etc.), you should definitely configure `g77' for +installation in `/usr/bin' instead of `/usr/local/bin'. Specify the +`--prefix=/usr' option when running `./configure'. You might also want +to set up the distribution so the `f77' command is a link to +`g77'--just make an empty file named `f77-install-ok' in the source or +build directory (the one in which the `f' directory resides, not the +`f' directory itself) when you specify one of the `install' or +`uninstall' targets in a `make' command. + + For a system that might already have `f2c' installed, you definitely +will want to make another empty file (in the same directory) named +either `f2c-exists-ok' or `f2c-install-ok'. Use the former if you +don't want your distribution to overwrite `f2c'-related files in +existing systems; use the latter if you want to improve the likelihood +that users will be able to use both `f2c' and `g77' to compile code for +a single program without encountering link-time or run-time +incompatibilities. + + (Make sure you clearly document, in the "advertising" for your +distribution, how installation of your distribution will affect +existing installations of `gcc', `f2c', `f77', `libf2c.a', and so on. +Similarly, you should clearly document any requirements you assume are +met by users of your distribution.) + + For other systems with native `f77' (and `cc') compilers, configure +`g77' as you (or most of your audience) would configure `gcc' for their +installations. Typically this is for installation in `/usr/local', and +would not include a copy of `g77' named `f77', so users could still use +the native `f77'. + + In any case, for `g77' to work properly, you *must* ensure that the +binaries you distribute include: + +`bin/g77' + This is the command most users use to compile Fortran. + +`bin/gcc' + This is the command all users use to compile Fortran, either + directly or indirectly via the `g77' command. The `bin/gcc' + executable file must have been built from a `gcc' source tree into + which a `g77' source tree was merged and configured, or it will + not know how to compile Fortran programs. + +`bin/f77' + In installations with no non-GNU native Fortran compiler, this is + the same as `bin/g77'. Otherwise, it should be omitted from the + distribution, so the one on already on a particular system does + not get overwritten. + +`info/g77.info*' + This is the documentation for `g77'. If it is not included, users + will have trouble understanding diagnostics messages and other + such things, and will send you a lot of email asking questions. + + Please edit this documentation (by editing `gcc/f/*.texi' and + doing `make doc' from the `/usr/src/gcc' directory) to reflect any + changes you've made to `g77', or at least to encourage users of + your binary distribution to report bugs to you first. + + Also, whether you distribute binaries or install `g77' on your own + system, it might be helpful for everyone to add a line listing + this manual by name and topic to the top-level `info' node in + `/usr/info/dir'. That way, users can find `g77' documentation more + easily. *Note Updating Your Info Directory: Updating + Documentation. + +`man/man1/g77.1' + This is the short man page for `g77'. It is out of date, but you + might as well include it for people who really like man pages. + +`man/man1/f77.1' + In installations where `f77' is the same as `g77', this is the + same as `man/man1/g77.1'. Otherwise, it should be omitted from + the distribution, so the one already on a particular system does + not get overwritten. + +`lib/gcc-lib/.../f771' + This is the actual Fortran compiler. + +`lib/gcc-lib/.../libf2c.a' + This is the run-time library for `g77'-compiled programs. + + Whether you want to include the slightly updated (and possibly +improved) versions of `cc1', `cc1plus', and whatever other binaries get +rebuilt with the changes the GNU Fortran distribution makes to the GNU +back end, is up to you. These changes are highly unlikely to break any +compilers, and it is possible they'll fix back-end bugs that can be +demonstrated using front ends other than GNU Fortran's. + + Please assure users that unless they have a specific need for their +existing, older versions of `gcc' command, they are unlikely to +experience any problems by overwriting it with your version--though +they could certainly protect themselves by making backup copies first! +Otherwise, users might try and install your binaries in a "safe" place, +find they cannot compile Fortran programs with your distribution +(because, perhaps, they're picking up their old version of the `gcc' +command, which does not recognize Fortran programs), and assume that +your binaries (or, more generally, GNU Fortran distributions in +general) are broken, at least for their system. + + Finally, *please* ask for bug reports to go to you first, at least +until you're sure your distribution is widely used and has been well +tested. This especially goes for those of you making any changes to +the `g77' sources to port `g77', e.g. to OS/2. + has received a fair number of bug reports that +turned out to be problems with other peoples' ports and distributions, +about which nothing could be done for the user. Once you are quite +certain a bug report does not involve your efforts, you can forward it +to us. + diff --git a/gcc/f/Make-lang.in b/gcc/f/Make-lang.in new file mode 100644 index 000000000000..7e59b6100c3a --- /dev/null +++ b/gcc/f/Make-lang.in @@ -0,0 +1,567 @@ +# Top level makefile fragment for GNU Fortran. -*-makefile-*- +# Copyright (C) 1995-1997 Free Software Foundation, Inc. + +#This file is part of GNU Fortran. + +#GNU Fortran is free software; you can redistribute it and/or modify +#it under the terms of the GNU General Public License as published by +#the Free Software Foundation; either version 2, or (at your option) +#any later version. + +#GNU Fortran is distributed in the hope that it will be useful, +#but WITHOUT ANY WARRANTY; without even the implied warranty of +#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +#GNU General Public License for more details. + +#You should have received a copy of the GNU General Public License +#along with GNU Fortran; see the file COPYING. If not, write to +#the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +#02111-1307, USA. + +# This file provides the language dependent support in the main Makefile. +# Each language makefile fragment must provide the following targets: +# +# foo.all.build, foo.all.cross, foo.start.encap, foo.rest.encap, +# foo.info, foo.dvi, +# foo.install-normal, foo.install-common, foo.install-info, foo.install-man, +# foo.uninstall, foo.distdir, +# foo.mostlyclean, foo.clean, foo.distclean, foo.extraclean, +# foo.maintainer-clean, foo.stage1, foo.stage2, foo.stage3, foo.stage4 +# +# where `foo' is the name of the language. +# +# It should also provide rules for: +# +# - making any compiler driver (eg: g77) +# - the compiler proper (eg: f771) +# - define the names for selecting the language in LANGUAGES. +# +# $(srcdir) must be set to the gcc/ source directory (not gcc/f/). + +# Extra flags to pass to recursive makes (and to sub-configure). +# Use different quoting rules compared with FLAGS_TO_PASS so we can use +# this to set environment variables as well +# Note that GCC_FOR_TARGET, GCC_FLAGS aren't in here -- treated separately. +F77_FLAGS_TO_PASS = \ + CROSS="$(CROSS)" \ + AR_FLAGS="$(AR_FLAGS)" \ + AR_FOR_TARGET="$(AR_FOR_TARGET)" \ + BISON="$(BISON)" \ + BISONFLAGS="$(BISONFLAGS)" \ + CC="$(CC)" \ + CFLAGS="$(CFLAGS)" \ + X_CFLAGS="$(X_CFLAGS)" \ + LDFLAGS="$(LDFLAGS)" \ + LEX="$(LEX)" \ + LEXFLAGS="$(LEXFLAGS)" \ + MAKEINFO="$(MAKEINFO)" \ + MAKEINFOFLAGS="$(MAKEINFOFLAGS)" \ + RANLIB_FOR_TARGET="$(RANLIB_FOR_TARGET)" \ + RANLIB_TEST_FOR_TARGET="$(RANLIB_TEST_FOR_TARGET)" \ + SHELL="$(SHELL)" \ + exec_prefix="$(exec_prefix)" \ + prefix="$(prefix)" \ + tooldir="$(tooldir)" \ + bindir="$(bindir)" \ + libsubdir="$(libsubdir)" +# "F77_FOR_BUILD=$(F77_FOR_BUILD)" \ +# "F77FLAGS=$(F77FLAGS)" \ +# "F77_FOR_TARGET=$(F77_FOR_TARGET)" + +# This flag controls whether to install (overwrite) f77 on this system, +# and also whether to uninstall it when using the uninstall target. +# As shipped, the flag is a test of whether the `f77_install_ok' +# file exists in the build or source directories (top level), but +# you can just change it here if you like. +F77_INSTALL_FLAG = [ -f f77-install-ok -o -f $(srcdir)/f77-install-ok ] + +# This flag is similar to F77_INSTALL_FLAG, but controls whether +# to install (ovewrite) f2c-related items on this system. Currently +# these are `include/f2c.h' and `lib/libf2c.a', though at some point +# `bin/f2c' itself might be added to the g77 distribution. +F2C_INSTALL_FLAG = [ -f f2c-install-ok -o -f $(srcdir)/f2c-install-ok ] + +# This flag controls whether it is safe to install gcc's libf2c.a +# even when there's already a lib/libf2c.a installed (which, unless +# F2C_INSTALL_FLAG is set, will be left alone). +F2CLIBOK = [ -f f2c-exists-ok -o -f $(srcdir)/f2c-exists-ok ] + +# Actual names to use when installing a native compiler. +F77_INSTALL_NAME = `t='$(program_transform_name)'; echo f77 | sed $$t` +G77_INSTALL_NAME = `t='$(program_transform_name)'; echo g77 | sed $$t` + +# Actual names to use when installing a cross-compiler. +F77_CROSS_NAME = `t='$(program_transform_cross_name)'; echo f77 | sed $$t` +G77_CROSS_NAME = `t='$(program_transform_cross_name)'; echo g77 | sed $$t` + +# Define the names for selecting f77 in LANGUAGES. +# Note that it would be nice to move the dependency on g77 +# into the F77 rule, but that needs a little bit of work +# to do the right thing within all.cross. +F77 f77: f771 f77-runtime + +# Tell GNU make to ignore these if they exist. +.PHONY: F77 f77 f77-runtime f77-runtime-unsafe f77.all.build f77.all.cross \ + f77.start.encap f77.rest.encap f77.info f77.dvi maybe-f2c \ + f77.install-normal install-libf77 install-f2c-all install-f2c-header \ + install-f2c-lib f77.install-common f77.install-info f77.install-man \ + f77.uninstall f77.mostlyclean f77.clean f77.distclean f77.extraclean \ + f77.maintainer-clean f77.realclean f77.stage1 f77.stage2 f77.stage3 \ + f77.stage4 f77.distdir f77.rebuilt + +# Create the compiler driver for g77 (only if `f77' is in LANGUAGES). +g77: $(srcdir)/f/g77.c $(srcdir)/f/zzz.c $(CONFIG_H) $(LIBDEPS) + case '$(LANGUAGES)' in \ + *f77*) \ + $(CC) $(ALL_CFLAGS) $(INCLUDES) $(LDFLAGS) \ + -o $@ $(srcdir)/f/g77.c $(srcdir)/f/zzz.c $(LIBS) ;; \ + esac + +# Create a version of the g77 driver which calls the cross-compiler +# (only if `f77' is in LANGUAGES). +g77-cross: $(srcdir)/f/g77.c $(srcdir)/f/zzz.c version.o $(LIBDEPS) + case '$(LANGUAGES)' in \ + *f77*) \ + $(CC) $(ALL_CFLAGS) $(INCLUDES) $(LDFLAGS) \ + -DGCC_NAME=\"$(GCC_CROSS_NAME)\" \ + -o $@ $(srcdir)/f/g77.c $(srcdir)/f/zzz.c $(LIBS) ;; \ + esac + +F77_SRCS = \ + $(srcdir)/f/assert.j \ + $(srcdir)/f/bad.c \ + $(srcdir)/f/bad.def \ + $(srcdir)/f/bad.h \ + $(srcdir)/f/bit.c \ + $(srcdir)/f/bit.h \ + $(srcdir)/f/bld-op.def \ + $(srcdir)/f/bld.c \ + $(srcdir)/f/bld.h \ + $(srcdir)/f/com-rt.def \ + $(srcdir)/f/com.c \ + $(srcdir)/f/com.h \ + $(srcdir)/f/config.j \ + $(srcdir)/f/convert.j \ + $(srcdir)/f/data.c \ + $(srcdir)/f/data.h \ + $(srcdir)/f/equiv.c \ + $(srcdir)/f/equiv.h \ + $(srcdir)/f/expr.c \ + $(srcdir)/f/expr.h \ + $(srcdir)/f/fini.c \ + $(srcdir)/f/flags.j \ + $(srcdir)/f/glimits.j \ + $(srcdir)/f/global.c \ + $(srcdir)/f/global.h \ + $(srcdir)/f/hconfig.j \ + $(srcdir)/f/implic.c \ + $(srcdir)/f/implic.h \ + $(srcdir)/f/input.j \ + $(srcdir)/f/info-b.def \ + $(srcdir)/f/info-k.def \ + $(srcdir)/f/info-w.def \ + $(srcdir)/f/info.c \ + $(srcdir)/f/info.h \ + $(srcdir)/f/intrin.c \ + $(srcdir)/f/intrin.def \ + $(srcdir)/f/intrin.h \ + $(srcdir)/f/lab.c \ + $(srcdir)/f/lab.h \ + $(srcdir)/f/lex.c \ + $(srcdir)/f/lex.h \ + $(srcdir)/f/malloc.c \ + $(srcdir)/f/malloc.h \ + $(srcdir)/f/name.c \ + $(srcdir)/f/name.h \ + $(srcdir)/f/parse.c \ + $(srcdir)/f/proj.c \ + $(srcdir)/f/proj.h \ + $(srcdir)/f/rtl.j \ + $(srcdir)/f/src.c \ + $(srcdir)/f/src.h \ + $(srcdir)/f/st.c \ + $(srcdir)/f/st.h \ + $(srcdir)/f/sta.c \ + $(srcdir)/f/sta.h \ + $(srcdir)/f/stb.c \ + $(srcdir)/f/stb.h \ + $(srcdir)/f/stc.c \ + $(srcdir)/f/stc.h \ + $(srcdir)/f/std.c \ + $(srcdir)/f/std.h \ + $(srcdir)/f/ste.c \ + $(srcdir)/f/ste.h \ + $(srcdir)/f/storag.c \ + $(srcdir)/f/storag.h \ + $(srcdir)/f/stp.c \ + $(srcdir)/f/stp.h \ + $(srcdir)/f/str-1t.fin \ + $(srcdir)/f/str-2t.fin \ + $(srcdir)/f/str-fo.fin \ + $(srcdir)/f/str-io.fin \ + $(srcdir)/f/str-nq.fin \ + $(srcdir)/f/str-op.fin \ + $(srcdir)/f/str-ot.fin \ + $(srcdir)/f/str.c \ + $(srcdir)/f/str.h \ + $(srcdir)/f/sts.c \ + $(srcdir)/f/sts.h \ + $(srcdir)/f/stt.c \ + $(srcdir)/f/stt.h \ + $(srcdir)/f/stu.c \ + $(srcdir)/f/stu.h \ + $(srcdir)/f/stv.c \ + $(srcdir)/f/stv.h \ + $(srcdir)/f/stw.c \ + $(srcdir)/f/stw.h \ + $(srcdir)/f/symbol.c \ + $(srcdir)/f/symbol.def \ + $(srcdir)/f/symbol.h \ + $(srcdir)/f/target.c \ + $(srcdir)/f/target.h \ + $(srcdir)/f/tconfig.j \ + $(srcdir)/f/tm.j \ + $(srcdir)/f/top.c \ + $(srcdir)/f/top.h \ + $(srcdir)/f/tree.j \ + $(srcdir)/f/type.c \ + $(srcdir)/f/type.h \ + $(srcdir)/f/where.c \ + $(srcdir)/f/where.h \ + $(srcdir)/f/zzz.c \ + $(srcdir)/f/zzz.h + +f771: $(P) $(F77_SRCS) $(LIBDEPS) stamp-objlist f/Makefile + $(MAKE) -f f/Makefile $(FLAGS_TO_PASS) VPATH=$(srcdir) srcdir=$(srcdir) f771 + +f/Makefile: $(srcdir)/f/Makefile.in $(srcdir)/configure + $(SHELL) config.status + +# Note that the runtime is built in the top-level directory rather +# than in f/runtime a la the Cygnus CHILL example; then xgcc -B./ will +# find it. Use an absolute name for GCC_FOR_TARGET (so we don't have +# to keep stage? links around everywhere) unless this value has been +# overridden from the default "./xgcc -B./", hence the case statement. +# We depend on GCC_PASSES through f/runtime/Makefile. +stmp-headers = stmp-headers # to be overrideable in unsafe version +# Depend on stmp-headers, not stmp-int-hdrs, since libF77 needs float.h. +f77-runtime: f/runtime/Makefile include/f2c.h $(stmp-headers) \ + f/runtime/libF77/Makefile f/runtime/libI77/Makefile f/runtime/libU77/Makefile + case "$(LANGUAGES)" in \ + *f77*) top=`pwd`; \ + cd f/runtime && $(MAKE) \ + GCC_FOR_TARGET="`case '$(GCC_FOR_TARGET)' in \ + './xgcc -B./') echo $${top}/xgcc -B$${top}/;; \ + *) echo '$(GCC_FOR_TARGET)';; esac`" \ + GCC_FLAGS="$(GCC_FLAGS)" $(F77_FLAGS_TO_PASS) \ + all ;; \ + esac + +# This one doesn't depend on cc1 etc. but f2c.h may not be found, +# in particular, at present... +f77-runtime-unsafe: + $(MAKE) stmp-headers= GCC_PARTS= f77-runtime + +# The configuration of the runtime system relies on an autoconf-type +# configure, not a Cygnus-type one. It needs to be run *after* the +# appropriate (cross-)compiler has been built, thus depend on GCC_PARTS. +# NB, sh uses the *first* value of $a from `a=fred a=joe prog'. +include/f2c.h \ +f/runtime/Makefile \ +f/runtime/libF77/Makefile \ +f/runtime/libI77/Makefile \ +f/runtime/libU77/Makefile: \ + $(srcdir)/f/runtime/f2c.h.in \ + $(srcdir)/f/com.h $(srcdir)/f/proj.h \ + $(srcdir)/f/runtime/Makefile.in \ + $(srcdir)/f/runtime/libF77/Makefile.in \ + $(srcdir)/f/runtime/libI77/Makefile.in \ + $(srcdir)/f/runtime/libU77/Makefile.in \ + $(srcdir)/f/runtime/configure \ + $(srcdir)/f/runtime/libU77/configure \ + $(GCC_PARTS) +# The make "stage?" in compiler spec. is fully qualified as above + top=`pwd`; \ + src=`cd $(srcdir); pwd`; \ + cd f/runtime; \ + CC="`case '$(GCC_FOR_TARGET)' in \ + './xgcc -B./') echo $${top}/xgcc -B$${top}/;; \ + *) echo '$(GCC_FOR_TARGET)';; esac`" \ + $(F77_FLAGS_TO_PASS) CONFIG_SITE=/dev/null $(SHELL) \ + $${src}/f/runtime/configure --srcdir=$${src}/f/runtime + top=`pwd`; \ + src=`cd $(srcdir); pwd`; \ + cd f/runtime/libU77; \ + CC="`case '$(GCC_FOR_TARGET)' in \ + './xgcc -B./') echo $${top}/xgcc -B$${top}/;; \ + *) echo '$(GCC_FOR_TARGET)';; esac`" \ + $(F77_FLAGS_TO_PASS) CONFIG_SITE=/dev/null $(SHELL) \ + $${src}/f/runtime/libU77/configure --srcdir=$${src}/f/runtime/libU77 + +#For now, omit f2c stuff. -- burley +#f2c: stmp-headers f/f2c/Makefile +# cd f/f2c; $(MAKE) all +# +#f/f2c/Makefile: $(srcdir)/f/f2c/Makefile.in $(GCC_PARTS) \ +# $(srcdir)/config/$(xmake_file) $(srcdir)/config/$(tmake_file) +# top=`pwd`; cd f/f2c; \ +# $${top}/f/f2c/configure --srcdir=$${top}/f/f2c + +# Build hooks: + +# I'm not sure there's a way of getting f2c into here conditionally on +# the --enable-f2c flag detected by config-lang.in so kluge it with the +# maybe-f2c target by looking at STAGESTUFF. +f77.all.build: g77 maybe-f2c +f77.all.cross: g77-cross maybe-f2c +f77.start.encap: g77 maybe-f2c +f77.rest.encap: + +f77.info: $(srcdir)/f/g77.info +f77.dvi: $(srcdir)/f/g77.dvi + +# g77 documentation. +$(srcdir)/f/g77.info: f/g77.texi f/bugs.texi f/install.texi f/news.texi f/intdoc.texi + cd $(srcdir)/f; $(MAKEINFO) g77.texi + +$(srcdir)/f/g77.dvi: f/g77.texi f/bugs.texi f/install.texi f/news.texi f/intdoc.texi + cd $(srcdir)/f; $(TEXI2DVI) g77.texi + +$(srcdir)/f/intdoc.texi: f/intdoc.c f/intdoc.h f/intrin.def f/intrin.h + $(HOST_CC) $(HOST_CFLAGS) $(HOST_LDFLAGS) \ + `echo $(srcdir)/f/intdoc.c | sed 's,^\./,,'` -o f/intdoc + f/intdoc > $(srcdir)/f/intdoc.texi + rm f/intdoc + +$(srcdir)/f/BUGS: f/bugs0.texi f/bugs.texi + cd $(srcdir)/f; $(MAKEINFO) -D BUGSONLY --no-header --no-split \ + --no-validate bugs0.texi -o BUGS + +$(srcdir)/f/INSTALL: f/install0.texi f/install.texi + cd $(srcdir)/f; $(MAKEINFO) -D INSTALLONLY --no-header --no-split \ + --no-validate install0.texi -o INSTALL + +$(srcdir)/f/NEWS: f/news0.texi f/news.texi + cd $(srcdir)/f; $(MAKEINFO) -D NEWSONLY --no-header --no-split \ + --no-validate news0.texi -o NEWS + +$(srcdir)/f/runtime/configure: $(srcdir)/f/runtime/configure.in + cd f/runtime && $(MAKE) srcdir=../../$(srcdir)/f/runtime -f ../../$(srcdir)/f/runtime/Makefile.in rebuilt +$(srcdir)/f/runtime/libU77/configure: $(srcdir)/f/runtime/libU77/configure.in + cd f/runtime && $(MAKE) srcdir=../../$(srcdir)/f/runtime -f ../../$(srcdir)/f/runtime/Makefile.in rebuilt + +f77.rebuilt: $(srcdir)/f/g77.info $(srcdir)/f/BUGS $(srcdir)/f/INSTALL \ + $(srcdir)/f/NEWS $(srcdir)/f/runtime/configure \ + $(srcdir)/f/runtime/libU77/configure + +maybe-f2c: +#For now, omit f2c stuff. -- burley +# case "$(STAGESTUFF)" in *f2c*) $(MAKE) f2c;; esac + +# Install hooks: +# f771 is installed elsewhere as part of $(COMPILERS). + +f77.install-normal: install-libf77 install-f2c-all + +# Install the F77 run time library. +install-libf77: f77-runtime +# Check for the presence of other versions of the library and includes. +# Test libf2c.* in case of a shared version, for instance. + @if test -z "$(F2CLIBOK)" && \ + test -z "$(F2C_INSTALL_FLAG)" && \ + test "`echo $(libdir)/libf2c.*`" != "$(libdir)/libf2c.*"; then \ + echo ; \ + echo 'You already have a version of libf2c installed as' $(libdir)/libf2c.*; \ + echo 'To use g77 this must be consistent with the one that will be built.'; \ + echo 'You should probably delete it and/or install ./libf2c.a in its place.'; \ + echo 'Resume the "make install" after removing the existing library or'; \ + echo 'define the make variable F2CLIBOK to avoid this test.'; \ + echo 'Check also for' $(includedir)/f2c.h 'per INSTALL instructions.'; \ + echo '(Note that a quick and easy way to resume "make -k install" is to'; \ + echo 'use "make install-libf77".)'; \ + exit 1; else true; fi + if [ -f libf2c.a ] ; then \ + $(INSTALL_DATA) libf2c.a $(libsubdir)/libf2c.a; \ + if $(RANLIB_TEST) ; then \ + (cd $(libsubdir); $(RANLIB) libf2c.a); else true; fi; \ + chmod a-x $(libsubdir)/libf2c.a; \ + else true; fi + if [ -f include/f2c.h ] ; then \ + $(INSTALL_DATA) include/f2c.h $(libsubdir)/include/f2c.h; \ + else true; fi + +# Install the f2c-related stuff in the directories +# where f2c and vanilla ld might look for them. + +install-f2c-all: install-f2c-header install-f2c-lib + +install-f2c-header: + -if test -n "$(F2C_INSTALL_FLAG)" && test -f include/f2c.h; then \ + $(INSTALL_DATA) include/f2c.h $(includedir)/f2c.h; \ + chmod a+r $(includedir)/f2c.h; \ + else true; fi + +install-f2c-lib: + -if test -n "$(F2C_INSTALL_FLAG)" && test -f libf2c.a; then \ + $(INSTALL_DATA) libf2c.a $(libdir)/libf2c.a; \ + if $(RANLIB_TEST) ; then \ + (cd $(libdir); $(RANLIB) libf2c.a); else true; fi; \ + chmod a-x $(libdir)/libf2c.a; \ + else true; fi + +# Install the driver program as $(target)-g77 +# and also as either g77 (if native) or $(tooldir)/bin/g77. +f77.install-common: + -if [ -f f771$(exeext) ] ; then \ + if [ -f g77-cross$(exeext) ] ; then \ + rm -f $(bindir)/$(G77_CROSS_NAME)$(exeext); \ + $(INSTALL_PROGRAM) g77-cross$(exeext) $(bindir)/$(G77_CROSS_NAME)$(exeext); \ + chmod a+x $(bindir)/$(G77_CROSS_NAME)$(exeext); \ + if $(F77_INSTALL_FLAG) ; then \ + rm -f $(bindir)/$(F77_CROSS_NAME)$(exeext); \ + ln $(bindir)/$(G77_CROSS_NAME)$(exeext) $(bindir)/$(F77_CROSS_NAME)$(exeext) \ + > /dev/null 2>&1 \ + || cp $(bindir)/$(G77_CROSS_NAME)$(exeext) $(bindir)/$(F77_CROSS_NAME)$(exeext) ; \ + fi ; \ + else \ + rm -f $(bindir)/$(G77_INSTALL_NAME)$(exeext); \ + $(INSTALL_PROGRAM) g77$(exeext) $(bindir)/$(G77_INSTALL_NAME)$(exeext); \ + chmod a+x $(bindir)/$(G77_INSTALL_NAME)$(exeext); \ + if $(F77_INSTALL_FLAG) ; then \ + rm -f $(bindir)/$(F77_INSTALL_NAME)$(exeext); \ + ln $(bindir)/$(G77_INSTALL_NAME)$(exeext) $(bindir)/$(F77_INSTALL_NAME)$(exeext) \ + > /dev/null 2>&1 \ + || cp $(bindir)/$(G77_INSTALL_NAME)$(exeext) $(bindir)/$(F77_INSTALL_NAME)$(exeext) ; \ + fi ; \ + fi ; \ + else true; fi + +f77.install-info: + -rm -f $(infodir)/g77.info* + cd $(srcdir)/f; for f in g77.info*; \ + do $(INSTALL_DATA) $$f $(infodir)/$$f; done + -chmod a-x $(infodir)/g77.info* + +f77.install-man: $(srcdir)/f/g77.1 + -if [ -f f771$(exeext) ] ; then \ + if [ -f g77-cross$(exeext) ] ; then \ + rm -f $(mandir)/$(G77_CROSS_NAME)$(manext); \ + $(INSTALL_DATA) $(srcdir)/f/g77.1 $(mandir)/$(G77_CROSS_NAME)$(manext); \ + chmod a-x $(mandir)/$(G77_CROSS_NAME)$(manext); \ + if $(F77_INSTALL_FLAG) ; then \ + rm -f $(mandir)/$(F77_CROSS_NAME)$(manext); \ + ln $(mandir)/$(G77_CROSS_NAME)$(manext) $(mandir)/$(F77_CROSS_NAME)$(manext) \ + > /dev/null 2>&1 \ + || cp $(mandir)/$(F77_CROSS_NAME)$(manext) $(mandir)/$(F77_CROSS_NAME)$(manext) ; \ + fi ;\ + else \ + rm -f $(mandir)/$(G77_INSTALL_NAME)$(manext); \ + $(INSTALL_DATA) $(srcdir)/f/g77.1 $(mandir)/$(G77_INSTALL_NAME)$(manext); \ + chmod a-x $(mandir)/$(G77_INSTALL_NAME)$(manext); \ + if $(F77_INSTALL_FLAG) ; then \ + rm -f $(mandir)/$(F77_INSTALL_NAME)$(manext); \ + ln $(mandir)/$(G77_INSTALL_NAME)$(manext) $(mandir)/$(F77_INSTALL_NAME)$(manext) \ + > /dev/null 2>&1 \ + || cp $(mandir)/$(F77_INSTALL_NAME)$(manext) $(mandir)/$(F77_INSTALL_NAME)$(manext) ; \ + fi ;\ + fi; \ + else true; fi + +f77.uninstall: + -if $(F77_INSTALL_FLAG) ; then \ + rm -rf $(bindir)/$(F77_INSTALL_NAME)$(exeext) ; \ + rm -rf $(bindir)/$(F77_CROSS_NAME)$(exeext) ; \ + rm -rf $(mandir)/$(F77_INSTALL_NAME)$(manext) ; \ + rm -rf $(mandir)/$(F77_CROSS_NAME)$(manext) ; \ + fi + -rm -rf $(bindir)/$(G77_INSTALL_NAME)$(exeext) + -rm -rf $(bindir)/$(G77_CROSS_NAME)$(exeext) + -rm -rf $(mandir)/$(G77_INSTALL_NAME)$(manext) + -rm -rf $(mandir)/$(G77_CROSS_NAME)$(manext) + -rm -rf $(infodir)/g77.info* + -rm -rf $(libsubdir)/libf2c.a + -if $(F2C_INSTALL_FLAG) ; then \ + rm -rf include/f2c.h ; \ + rm -rf $(libdir)/libf2c.a ; \ + fi + +# Clean hooks: +# A lot of the ancillary files are deleted by the main makefile. +# We just have to delete files specific to us. + +f77.mostlyclean: + -rm -f f/*$(objext) + -rm -f f/fini f/f771 f/stamp-str f/str-*.h f/str-*.j f/intdoc + -cd f/runtime; $(MAKE) -f ../../$(srcdir)/f/runtime/Makefile.in mostlyclean +f77.clean: + -cd f/runtime; $(MAKE) -f ../../$(srcdir)/f/runtime/Makefile.in clean +f77.distclean: + -cd f/runtime; $(MAKE) -f ../../$(srcdir)/f/runtime/Makefile.in distclean + -rm -f f/Makefile +# like gcc's extraclean, which does clean f/ for us, but not f/gbe, +# f/runtime, f/runtime/libF77, f/runtime/libI77, and f/runtime/libU77, +# so do those. +f77.extraclean: f77.distclean + -rm -f f/*/=* f/*/"#"* f/*/*~* + -rm -f f/*/patch* f/*/*.orig f/*/*.rej + -rm -f f/*/*.dvi f/*/*.oaux f/*/*.d f/*/*.[zZ] f/*/*.gz + -rm -f f/*/*.tar f/*/*.xtar f/*/*diff f/*/*.diff.* f/*/*.tar.* f/*/*.xtar.* f/*/*diffs + -rm -f f/*/*lose f/*/*.s f/*/*.s[0-9] f/*/*.i + -rm -f f/*/*/=* f/*/*/"#"* f/*/*/*~* + -rm -f f/*/*/patch* f/*/*/*.orig f/*/*/*.rej + -rm -f f/*/*/*.dvi f/*/*/*.oaux f/*/*/*.d f/*/*/*.[zZ] f/*/*/*.gz + -rm -f f/*/*/*.tar f/*/*/*.xtar f/*/*/*diff f/*/*/*.diff.* f/*/*/*.tar.* f/*/*/*.xtar.* f/*/*/*diffs + -rm -f f/*/*/*lose f/*/*/*.s f/*/*/*.s[0-9] f/*/*/*.i +# realclean is the pre-2.7.0 name for maintainer-clean +f77.maintainer-clean f77.realclean: f77.distclean + -cd f/runtime; $(MAKE) -f ../../$(srcdir)/f/runtime/Makefile.in maintainer-clean + -$(MAKE) f77.maintainer-clean + -rm -f f/g77.info* f/g77.*aux f/TAGS f/BUGS f/INSTALL f/NEWS f/intdoc.texi + +# Stage hooks: +# The main makefile has already created stage?/f. + +G77STAGESTUFF = f/*$(objext) f/fini f/stamp-str f/str-*.h f/str-*.j +RUNTIMESTAGESTUFF = f/runtime/config.cache f/runtime/config.log \ + f/runtime/config.status f/runtime/Makefile f/runtime/stamp-lib +LIBF77STAGESTUFF = f/runtime/libF77/*$(objext) f/runtime/libF77/Makefile +LIBI77STAGESTUFF = f/runtime/libI77/*$(objext) f/runtime/libI77/Makefile +LIBU77STAGESTUFF = f/runtime/libU77/*$(objext) f/runtime/libU77/Makefile \ + f/runtime/libU77/config.cache f/runtime/libU77/config.log \ + f/runtime/libU77/config.status + +f77.stage1: + -mv $(G77STAGESTUFF) stage1/f + -mv $(RUNTIMESTAGESTUFF) stage1/f/runtime + -mv $(LIBF77STAGESTUFF) stage1/f/runtime/libF77 + -mv $(LIBI77STAGESTUFF) stage1/f/runtime/libI77 + -mv $(LIBU77STAGESTUFF) stage1/f/runtime/libU77 +f77.stage2: + -mv $(G77STAGESTUFF) stage2/f + -mv $(RUNTIMESTAGESTUFF) stage2/f/runtime + -mv $(LIBF77STAGESTUFF) stage2/f/runtime/libF77 + -mv $(LIBI77STAGESTUFF) stage2/f/runtime/libI77 + -mv $(LIBU77STAGESTUFF) stage2/f/runtime/libU77 +f77.stage3: + -mv $(G77STAGESTUFF) stage3/f + -mv $(RUNTIMESTAGESTUFF) stage3/f/runtime + -mv $(LIBF77STAGESTUFF) stage3/f/runtime/libF77 + -mv $(LIBI77STAGESTUFF) stage3/f/runtime/libI77 + -mv $(LIBU77STAGESTUFF) stage3/f/runtime/libU77 +f77.stage4: + -mv $(G77STAGESTUFF) stage4/f + -mv $(RUNTIMESTAGESTUFF) stage4/f/runtime + -mv $(LIBF77STAGESTUFF) stage4/f/runtime/libF77 + -mv $(LIBI77STAGESTUFF) stage4/f/runtime/libI77 + -mv $(LIBU77STAGESTUFF) stage4/f/runtime/libU77 + +# Maintenance hooks: + +# This target creates the files that can be rebuilt, but go in the +# distribution anyway. It then copies the files to the distdir directory. +f77.distdir: f77.rebuilt + mkdir tmp/f + cd f; \ + for file in *[0-9a-zA-Z+]; do \ + ln $$file ../tmp/f >/dev/null 2>&1 || cp $$file ../tmp/f; \ + done diff --git a/gcc/f/Makefile.in b/gcc/f/Makefile.in new file mode 100644 index 000000000000..79eba82a3a9f --- /dev/null +++ b/gcc/f/Makefile.in @@ -0,0 +1,562 @@ +# Makefile for GNU F77 compiler. +# Copyright (C) 1995-1997 Free Software Foundation, Inc. + +#This file is part of GNU Fortran. + +#GNU Fortran is free software; you can redistribute it and/or modify +#it under the terms of the GNU General Public License as published by +#the Free Software Foundation; either version 2, or (at your option) +#any later version. + +#GNU Fortran is distributed in the hope that it will be useful, +#but WITHOUT ANY WARRANTY; without even the implied warranty of +#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +#GNU General Public License for more details. + +#You should have received a copy of the GNU General Public License +#along with GNU Fortran; see the file COPYING. If not, write to +#the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +#02111-1307, USA. + +# The makefile built from this file lives in the language subdirectory. +# Its purpose is to provide support for: +# +# 1) recursion where necessary, and only then (building .o's), and +# 2) building and debugging f771 from the language subdirectory, and +# 3) nothing else. +# +# The parent makefile handles all other chores, with help from the +# language makefile fragment, of course. +# +# The targets for external use are: +# all, TAGS, ???mostlyclean, ???clean. + +# Suppress smart makes who think they know how to automake Yacc files +.y.c: + +# Variables that exist for you to override. +# See below for how to change them for certain systems. + +ALLOCA = + +# Various ways of specifying flags for compilations: +# CFLAGS is for the user to override to, e.g., do a bootstrap with -O2. +# BOOT_CFLAGS is the value of CFLAGS to pass +# to the stage2 and stage3 compilations +# XCFLAGS is used for most compilations but not when using the GCC just built. +XCFLAGS = +CFLAGS = -g +BOOT_CFLAGS = -O $(CFLAGS) +# These exists to be overridden by the x-* and t-* files, respectively. +X_CFLAGS = +T_CFLAGS = + +X_CPPFLAGS = +T_CPPFLAGS = + +CC = cc +HOST_CC = $(CC) +BISON = bison +BISONFLAGS = +LEX = flex +LEXFLAGS = +AR = ar +AR_FLAGS = rc +SHELL = /bin/sh +MAKEINFO = makeinfo +TEXI2DVI = texi2dvi + +# Define this as & to perform parallel make on a Sequent. +# Note that this has some bugs, and it seems currently necessary +# to compile all the gen* files first by hand to avoid erroneous results. +P = + +# This is used in the definition of SUBDIR_USE_ALLOCA. +# ??? Perhaps it would be better if it just looked for *gcc*. +OLDCC = cc + +# This is used instead of ALL_CFLAGS when compiling with GCC_FOR_TARGET. +# It omits XCFLAGS, and specifies -B./. +# It also specifies -B$(tooldir)/ to find as and ld for a cross compiler. +GCC_CFLAGS=$(INTERNAL_CFLAGS) $(X_CFLAGS) $(T_CFLAGS) $(CFLAGS) + +# Tools to use when building a cross-compiler. +# These are used because `configure' appends `cross-make' +# to the makefile when making a cross-compiler. + +target= ... `configure' substitutes actual target name here. +xmake_file= ... `configure' substitutes actual x- file name here. +tmake_file= ... `configure' substitutes actual t- file name here. + +# Directory where gcc sources are (gcc/), from where we are. +# Note that this should be overridden when building f771, which happens +# at the top level, not in f. Likewise for VPATH (if added). +srcdir = . +VPATH = . + +# Additional system libraries to link with. +CLIB= + +# Change this to a null string if obstacks are installed in the +# system library. +OBSTACK=obstack.o + +# Choose the real default target. +ALL=all + +# End of variables for you to override. + +# Definition of `none' is here so that new rules inserted by sed +# do not specify the default target. +none: + @echo '' + @echo 'Do not use this makefile to build anything other than the' + @echo 'g77 derived files via the "make g77-only" target.' + @echo 'Instead, use the documented procedures to build gcc itself,' + @echo 'which will build g77 as well when done properly.' + @echo '' + @exit 1 + +# This rule is just a handy way to build the g77 derived files without +# having the gcc source tree around. +g77-only: force + if [ -f g77.texi ] ; then \ + (cd ..; $(MAKE) srcdir=. HOST_CC=cc HOST_CFLAGS=-g -f f/Make-lang.in f77.rebuilt); \ + else \ + $(MAKE) srcdir=. HOST_CC=cc HOST_CFLAGS=-g -f f/Make-lang.in f77.rebuilt; \ + fi + +all: all.indirect + +# This tells GNU Make version 3 not to put all variables in the environment. +.NOEXPORT: + +# sed inserts variable overrides after the following line. +####target overrides +####host overrides +####cross overrides +####build overrides + +# Now figure out from those variables how to compile and link. + +all.indirect: f/Makefile f771 + +# IN_GCC tells obstack.h that we are using gcc's file. +INTERNAL_CFLAGS = $(CROSS) -DIN_GCC + +# This is the variable actually used when we compile. +ALL_CFLAGS = $(INTERNAL_CFLAGS) $(X_CFLAGS) $(T_CFLAGS) $(CFLAGS) $(XCFLAGS) -W -Wall + +# Likewise. +ALL_CPPFLAGS = $(CPPFLAGS) $(X_CPPFLAGS) $(T_CPPFLAGS) + +# f771 is so big, need to tell linker on m68k-next-nextstep* to make enough +# room for it. On AIX, linking f771 overflows the linker TOC. -bbigtoc is +# appropriate for the linker on AIX 4.1 and above. +F771_LDFLAGS = `case "${target}" in\ + m68k-next-nextstep*) echo -segaddr __DATA 6000000;;\ + *-*-aix[4-9]*) \`$(CC) --print-prog-name=ld\` -v 2>&1 | grep BFD >/dev/null || echo -Wl,-bbigtoc;; esac` + +# Even if ALLOCA is set, don't use it if compiling with GCC. + +SUBDIR_OBSTACK = `if [ x$(OBSTACK) != x ]; then echo $(OBSTACK); else true; fi` +SUBDIR_USE_ALLOCA = `case "${CC}" in "${OLDCC}") if [ x$(ALLOCA) != x ]; then echo $(ALLOCA); else true; fi ;; esac` +SUBDIR_MALLOC = `if [ x$(MALLOC) != x ]; then echo $(MALLOC); else true; fi` + +# How to link with both our special library facilities +# and the system's installed libraries. +LIBS = $(SUBDIR_OBSTACK) $(SUBDIR_USE_ALLOCA) $(SUBDIR_MALLOC) $(CLIB) + +# Specify the directories to be searched for header files. +# Both . and srcdir are used, in that order, +# so that tm.h and config.h will be found in the compilation +# directory rather than in the source directory. +INCLUDES = -If -I$(srcdir)/f -I. -I$(srcdir) -I$(srcdir)/config + +# Flags_to_pass to recursive makes. +# Note that we don't need to distinguish the `_FOR_TARGET' cross tools +# as AR and RANLIB are set appropriately by configure iff cross compiling. +FLAGS_TO_PASS = \ + "CROSS=$(CROSS)" \ + "AR_FLAGS=$(AR_FLAGS)" \ + "AR=$(AR)" \ + "BISON=$(BISON)" \ + "BISONFLAGS=$(BISONFLAGS)" \ + "CC=$(CC)" \ + "CFLAGS=$(CFLAGS)" \ + "GCCFLAGS=$(GCCFLAGS)" \ + "GCC_FOR_TARGET=$(GCC_FOR_TARGET)" \ + "LDFLAGS=$(LDFLAGS)" \ + "LEX=$(LEX)" \ + "LEXFLAGS=$(LEXFLAGS)" \ + "MAKEINFO=$(MAKEINFO)" \ + "MAKEINFOFLAGS=$(MAKEINFOFLAGS)" \ + "RANLIB=$(RANLIB)" \ + "RANLIB_TEST=$(RANLIB_TEST)" \ + "SHELL=$(SHELL)" \ + "exec_prefix=$(exec_prefix)" \ + "prefix=$(prefix)" \ + "tooldir=$(tooldir)" \ + "bindir=$(bindir)" \ + "libsubdir=$(libsubdir)" + +.c.o: + $(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $< -o $@ + +# Lists of files for various purposes. + +# Language-specific object files for g77 + +F77_OBJS = \ + f/bad.o \ + f/bit.o \ + f/bld.o \ + f/com.o \ + f/data.o \ + f/equiv.o \ + f/expr.o \ + f/global.o \ + f/implic.o \ + f/info.o \ + f/intrin.o \ + f/lab.o \ + f/lex.o \ + f/malloc.o \ + f/name.o \ + f/parse.o \ + f/proj.o \ + f/src.o \ + f/st.o \ + f/sta.o \ + f/stb.o \ + f/stc.o \ + f/std.o \ + f/ste.o \ + f/storag.o \ + f/stp.o \ + f/str.o \ + f/sts.o \ + f/stt.o \ + f/stu.o \ + f/stv.o \ + f/stw.o \ + f/symbol.o \ + f/target.o \ + f/top.o \ + f/type.o \ + f/where.o \ + f/zzz.o + +# Language-independent object files. +OBJS = `cat stamp-objlist | sed -e "s: : :g" -e "s: : f/:g"` +OBJDEPS = stamp-objlist + +compiler: f771 +# This is now meant to be built in the top level directory, not `f': +f771: $(P) f/Makefile $(F77_OBJS) $(OBJDEPS) $(LIBDEPS) + rm -f f771$(exeext) + $(CC) $(ALL_CFLAGS) $(LDFLAGS) $(F771_LDFLAGS) -o $@ \ + $(F77_OBJS) $(OBJS) $(LIBS) + +# Check in case anyone expects to build in this directory: +f/Makefile: + @if test ! -f f/Makefile ; \ + then echo "Build f771 only at the top level." 2>&1; exit 1; \ + else true; fi + +Makefile: $(srcdir)/f/Makefile.in $(srcdir)/configure + +native: f771 + +# Compiling object files from source files. + +# Note that dependencies on obstack.h are not written +# because that file is not part of GCC. + +# F77 language-specific files. + +# These macros expand to the corresponding g77-source .j files plus +# the gcc-source files involved (each file itself, plus whatever +# files on which it depends, but without including stuff resulting +# from configuration, since we can't guess at that). The files +# that live in a distclean'd gcc source directory have "$(srcdir)/" +# prefixes, while the others don't because they'll be created +# only in the build directory. +ASSERT_H = $(srcdir)/f/assert.j $(srcdir)/assert.h +CONFIG_H = $(srcdir)/f/config.j config.h +CONVERT_H = $(srcdir)/f/convert.j $(srcdir)/convert.h +FLAGS_H = $(srcdir)/f/flags.j $(srcdir)/flags.h +GLIMITS_H = $(srcdir)/f/glimits.j $(srcdir)/glimits.h +HCONFIG_H = $(srcdir)/f/hconfig.j hconfig.h +INPUT_H = $(srcdir)/f/input.j $(srcdir)/input.h +RTL_H = $(srcdir)/f/rtl.j $(srcdir)/rtl.h $(srcdir)/rtl.def \ + $(srcdir)/machmode.h $(srcdir)/machmode.def +TCONFIG_H = $(srcdir)/f/tconfig.j tconfig.h +TM_H = $(srcdir)/f/tm.j tm.h +TREE_H = $(srcdir)/f/tree.j $(srcdir)/tree.h $(srcdir)/real.h \ + $(srcdir)/tree.def $(srcdir)/machmode.h $(srcdir)/machmode.def + +#Build the first part of this list with the command line: +# cd gcc/; make deps-kinda -f f/Makefile.in +#Note that this command uses the host C compiler; +# use HOST_CC="./xgcc -B./" to use GCC in the build directory, for example. +#Also note that this particular build file seems to want to use +# substitions: $(CONFIG_H) for config.h; $(TREE_H) for tree.h; and +# $(RTL_H) for rtl.h. deps-kinda uses a sed script to do those +# substitutions, plus others for elegance. + +f/bad.o: f/bad.c f/proj.h $(ASSERT_H) f/bad.h f/bad.def f/where.h $(GLIMITS_H) \ + f/top.h f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/bld.h f/bld-op.def f/bit.h \ + f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h f/lex.h f/type.h \ + f/intrin.h f/intrin.def f/lab.h f/symbol.h f/symbol.def f/equiv.h f/storag.h \ + f/global.h f/name.h +f/bit.o: f/bit.c f/proj.h $(ASSERT_H) $(GLIMITS_H) f/bit.h f/malloc.h +f/bld.o: f/bld.c f/proj.h $(ASSERT_H) f/bld.h f/bld-op.def f/bit.h f/malloc.h \ + f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def f/info-w.def \ + f/target.h f/bad.h f/bad.def f/where.h $(GLIMITS_H) f/top.h f/lex.h f/type.h \ + f/lab.h f/storag.h f/symbol.h f/symbol.def f/equiv.h f/global.h f/name.h \ + f/intrin.h f/intrin.def +f/com.o: f/com.c $(CONFIG_H) $(FLAGS_H) $(RTL_H) $(TREE_H) $(CONVERT_H) f/proj.h \ + $(ASSERT_H) f/com.h f/com-rt.def f/bld.h f/bld-op.def f/bit.h f/malloc.h \ + f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def \ + f/where.h $(GLIMITS_H) f/top.h f/lex.h f/type.h f/intrin.h f/intrin.def f/lab.h \ + f/symbol.h f/symbol.def f/equiv.h f/storag.h f/global.h f/name.h f/expr.h \ + f/implic.h f/src.h f/st.h +f/data.o: f/data.c f/proj.h $(ASSERT_H) f/data.h f/bld.h f/bld-op.def f/bit.h \ + f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def \ + f/info-w.def f/target.h f/bad.h f/bad.def f/where.h $(GLIMITS_H) f/top.h f/lex.h \ + f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def f/equiv.h f/global.h \ + f/name.h f/intrin.h f/intrin.def f/expr.h f/st.h +f/equiv.o: f/equiv.c f/proj.h $(ASSERT_H) f/equiv.h f/bld.h f/bld-op.def f/bit.h \ + f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def \ + f/info-w.def f/target.h f/bad.h f/bad.def f/where.h $(GLIMITS_H) f/top.h f/lex.h \ + f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def f/global.h f/name.h \ + f/intrin.h f/intrin.def f/data.h +f/expr.o: f/expr.c f/proj.h $(ASSERT_H) f/expr.h f/bld.h f/bld-op.def f/bit.h \ + f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def \ + f/info-w.def f/target.h f/bad.h f/bad.def f/where.h $(GLIMITS_H) f/top.h f/lex.h \ + f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def f/equiv.h f/global.h \ + f/name.h f/intrin.h f/intrin.def f/implic.h f/src.h f/st.h +f/fini.o: f/fini.c f/proj.h $(ASSERT_H) f/malloc.h +f/g77.o: f/g77.c $(CONFIG_H) +f/global.o: f/global.c f/proj.h $(ASSERT_H) f/global.h f/lex.h f/top.h f/malloc.h \ + f/where.h $(GLIMITS_H) f/name.h f/symbol.h f/symbol.def f/bad.h f/bad.def \ + f/bld.h f/bld-op.def f/bit.h f/com.h f/com-rt.def $(TREE_H) f/info.h \ + f/info-b.def f/info-k.def f/info-w.def f/target.h f/type.h f/lab.h f/storag.h \ + f/intrin.h f/intrin.def f/equiv.h +f/implic.o: f/implic.c f/proj.h $(ASSERT_H) f/implic.h f/info.h f/info-b.def \ + f/info-k.def f/info-w.def f/target.h $(TREE_H) f/bad.h f/bad.def f/where.h \ + $(GLIMITS_H) f/top.h f/malloc.h f/lex.h f/type.h f/symbol.h f/symbol.def f/bld.h \ + f/bld-op.def f/bit.h f/com.h f/com-rt.def f/lab.h f/storag.h f/intrin.h \ + f/intrin.def f/equiv.h f/global.h f/name.h f/src.h +f/info.o: f/info.c f/proj.h $(ASSERT_H) f/info.h f/info-b.def f/info-k.def \ + f/info-w.def f/target.h $(TREE_H) f/bad.h f/bad.def f/where.h $(GLIMITS_H) \ + f/top.h f/malloc.h f/lex.h f/type.h +f/intrin.o: f/intrin.c f/proj.h $(ASSERT_H) f/intrin.h f/intrin.def f/bld.h \ + f/bld-op.def f/bit.h f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h \ + f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def f/where.h \ + $(GLIMITS_H) f/top.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def \ + f/equiv.h f/global.h f/name.h f/src.h +f/lab.o: f/lab.c f/proj.h $(ASSERT_H) f/lab.h f/com.h f/com-rt.def $(TREE_H) f/bld.h \ + f/bld-op.def f/bit.h f/malloc.h f/info.h f/info-b.def f/info-k.def \ + f/info-w.def f/target.h f/bad.h f/bad.def f/where.h $(GLIMITS_H) f/top.h f/lex.h \ + f/type.h f/intrin.h f/intrin.def f/symbol.h f/symbol.def f/equiv.h f/storag.h \ + f/global.h f/name.h +f/lex.o: f/lex.c f/proj.h $(ASSERT_H) f/top.h f/malloc.h f/where.h $(GLIMITS_H) \ + f/bad.h f/bad.def f/com.h f/com-rt.def $(TREE_H) f/bld.h f/bld-op.def f/bit.h \ + f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h f/lex.h f/type.h \ + f/intrin.h f/intrin.def f/lab.h f/symbol.h f/symbol.def f/equiv.h f/storag.h \ + f/global.h f/name.h f/src.h $(CONFIG_H) $(FLAGS_H) $(INPUT_H) +f/malloc.o: f/malloc.c f/proj.h $(ASSERT_H) f/malloc.h +f/name.o: f/name.c f/proj.h $(ASSERT_H) f/bad.h f/bad.def f/where.h $(GLIMITS_H) \ + f/top.h f/malloc.h f/name.h f/global.h f/lex.h f/symbol.h f/symbol.def f/bld.h \ + f/bld-op.def f/bit.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def \ + f/info-k.def f/info-w.def f/target.h f/type.h f/lab.h f/storag.h f/intrin.h \ + f/intrin.def f/equiv.h f/src.h +f/parse.o: f/parse.c f/proj.h $(ASSERT_H) f/top.h f/malloc.h f/where.h $(GLIMITS_H) \ + f/com.h f/com-rt.def $(TREE_H) f/bld.h f/bld-op.def f/bit.h f/info.h \ + f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def f/lex.h \ + f/type.h f/intrin.h f/intrin.def f/lab.h f/symbol.h f/symbol.def f/equiv.h \ + f/storag.h f/global.h f/name.h f/zzz.h $(FLAGS_H) +f/proj.o: f/proj.c f/proj.h $(ASSERT_H) $(GLIMITS_H) +f/src.o: f/src.c f/proj.h $(ASSERT_H) f/src.h f/bad.h f/bad.def f/where.h \ + $(GLIMITS_H) f/top.h f/malloc.h +f/st.o: f/st.c f/proj.h $(ASSERT_H) f/st.h f/bad.h f/bad.def f/where.h $(GLIMITS_H) \ + f/top.h f/malloc.h f/lex.h f/symbol.h f/symbol.def f/bld.h f/bld-op.def f/bit.h \ + f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def f/info-w.def \ + f/target.h f/type.h f/lab.h f/storag.h f/intrin.h f/intrin.def f/equiv.h \ + f/global.h f/name.h f/sta.h f/stamp-str f/stb.h f/expr.h f/stp.h f/stt.h f/stc.h \ + f/std.h f/stv.h f/stw.h f/ste.h f/sts.h f/stu.h +f/sta.o: f/sta.c f/proj.h $(ASSERT_H) f/sta.h f/bad.h f/bad.def f/where.h \ + $(GLIMITS_H) f/top.h f/malloc.h f/lex.h f/stamp-str f/symbol.h f/symbol.def f/bld.h \ + f/bld-op.def f/bit.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def \ + f/info-k.def f/info-w.def f/target.h f/type.h f/lab.h f/storag.h f/intrin.h \ + f/intrin.def f/equiv.h f/global.h f/name.h f/implic.h f/stb.h f/expr.h f/stp.h \ + f/stt.h f/stc.h f/std.h f/stv.h f/stw.h +f/stb.o: f/stb.c f/proj.h $(ASSERT_H) f/stb.h f/bad.h f/bad.def f/where.h \ + $(GLIMITS_H) f/top.h f/malloc.h f/expr.h f/bld.h f/bld-op.def f/bit.h f/com.h \ + f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def f/info-w.def \ + f/target.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def \ + f/equiv.h f/global.h f/name.h f/intrin.h f/intrin.def f/stp.h f/stt.h f/stamp-str \ + f/src.h f/sta.h f/stc.h +f/stc.o: f/stc.c f/proj.h $(ASSERT_H) f/stc.h f/bad.h f/bad.def f/where.h \ + $(GLIMITS_H) f/top.h f/malloc.h f/bld.h f/bld-op.def f/bit.h f/com.h \ + f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def f/info-w.def \ + f/target.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def \ + f/equiv.h f/global.h f/name.h f/intrin.h f/intrin.def f/expr.h f/stp.h f/stt.h \ + f/stamp-str f/data.h f/implic.h f/src.h f/sta.h f/std.h f/stv.h f/stw.h +f/std.o: f/std.c f/proj.h $(ASSERT_H) f/std.h f/bld.h f/bld-op.def f/bit.h \ + f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def \ + f/info-w.def f/target.h f/bad.h f/bad.def f/where.h $(GLIMITS_H) f/top.h f/lex.h \ + f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def f/equiv.h f/global.h \ + f/name.h f/intrin.h f/intrin.def f/stp.h f/stt.h f/stamp-str f/stv.h f/stw.h f/sta.h \ + f/ste.h f/sts.h +f/ste.o: f/ste.c $(CONFIG_H) $(RTL_H) f/proj.h $(ASSERT_H) f/ste.h f/bld.h \ + f/bld-op.def f/bit.h f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h \ + f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def f/where.h \ + $(GLIMITS_H) f/top.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def \ + f/equiv.h f/global.h f/name.h f/intrin.h f/intrin.def f/stp.h f/stt.h f/stamp-str \ + f/sts.h f/stv.h f/stw.h f/sta.h +f/storag.o: f/storag.c f/proj.h $(ASSERT_H) f/storag.h f/bld.h f/bld-op.def f/bit.h \ + f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def \ + f/info-w.def f/target.h f/bad.h f/bad.def f/where.h $(GLIMITS_H) f/top.h f/lex.h \ + f/type.h f/lab.h f/symbol.h f/symbol.def f/equiv.h f/global.h f/name.h \ + f/intrin.h f/intrin.def f/data.h +f/stp.o: f/stp.c f/proj.h $(ASSERT_H) f/stp.h f/bld.h f/bld-op.def f/bit.h \ + f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def \ + f/info-w.def f/target.h f/bad.h f/bad.def f/where.h $(GLIMITS_H) f/top.h f/lex.h \ + f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def f/equiv.h f/global.h \ + f/name.h f/intrin.h f/intrin.def f/stt.h +f/str.o: f/str.c f/proj.h $(ASSERT_H) f/src.h f/bad.h f/bad.def f/where.h \ + $(GLIMITS_H) f/top.h f/malloc.h f/stamp-str f/lex.h +f/sts.o: f/sts.c f/proj.h $(ASSERT_H) f/sts.h f/malloc.h f/com.h f/com-rt.def \ + $(TREE_H) f/bld.h f/bld-op.def f/bit.h f/info.h f/info-b.def f/info-k.def \ + f/info-w.def f/target.h f/bad.h f/bad.def f/where.h $(GLIMITS_H) f/top.h f/lex.h \ + f/type.h f/intrin.h f/intrin.def f/lab.h f/symbol.h f/symbol.def f/equiv.h \ + f/storag.h f/global.h f/name.h +f/stt.o: f/stt.c f/proj.h $(ASSERT_H) f/stt.h f/top.h f/malloc.h f/where.h \ + $(GLIMITS_H) f/bld.h f/bld-op.def f/bit.h f/com.h f/com-rt.def $(TREE_H) f/info.h \ + f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def f/lex.h \ + f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def f/equiv.h f/global.h \ + f/name.h f/intrin.h f/intrin.def f/stp.h f/expr.h f/sta.h f/stamp-str +f/stu.o: f/stu.c f/proj.h $(ASSERT_H) f/bld.h f/bld-op.def f/bit.h f/malloc.h \ + f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def f/info-w.def \ + f/target.h f/bad.h f/bad.def f/where.h $(GLIMITS_H) f/top.h f/lex.h f/type.h \ + f/lab.h f/storag.h f/symbol.h f/symbol.def f/equiv.h f/global.h f/name.h \ + f/intrin.h f/intrin.def f/implic.h f/stu.h f/sta.h f/stamp-str +f/stv.o: f/stv.c f/proj.h $(ASSERT_H) f/stv.h f/lab.h f/com.h f/com-rt.def $(TREE_H) \ + f/bld.h f/bld-op.def f/bit.h f/malloc.h f/info.h f/info-b.def f/info-k.def \ + f/info-w.def f/target.h f/bad.h f/bad.def f/where.h $(GLIMITS_H) f/top.h f/lex.h \ + f/type.h f/intrin.h f/intrin.def f/symbol.h f/symbol.def f/equiv.h f/storag.h \ + f/global.h f/name.h +f/stw.o: f/stw.c f/proj.h $(ASSERT_H) f/stw.h f/bld.h f/bld-op.def f/bit.h \ + f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def \ + f/info-w.def f/target.h f/bad.h f/bad.def f/where.h $(GLIMITS_H) f/top.h f/lex.h \ + f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def f/equiv.h f/global.h \ + f/name.h f/intrin.h f/intrin.def f/stv.h f/sta.h f/stamp-str +f/symbol.o: f/symbol.c f/proj.h $(ASSERT_H) f/symbol.h f/symbol.def f/bad.h \ + f/bad.def f/where.h $(GLIMITS_H) f/top.h f/malloc.h f/bld.h f/bld-op.def f/bit.h \ + f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def f/info-w.def \ + f/target.h f/lex.h f/type.h f/lab.h f/storag.h f/intrin.h f/intrin.def \ + f/equiv.h f/global.h f/name.h f/src.h f/st.h +f/target.o: f/target.c f/proj.h $(ASSERT_H) $(GLIMITS_H) f/target.h $(TREE_H) f/bad.h \ + f/bad.def f/where.h f/top.h f/malloc.h f/info.h f/info-b.def f/info-k.def \ + f/info-w.def f/type.h f/lex.h +f/top.o: f/top.c f/proj.h $(ASSERT_H) f/top.h f/malloc.h f/where.h $(GLIMITS_H) \ + f/bad.h f/bad.def f/bit.h f/bld.h f/bld-op.def f/com.h f/com-rt.def $(TREE_H) \ + f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h f/lex.h f/type.h \ + f/lab.h f/storag.h f/symbol.h f/symbol.def f/equiv.h f/global.h f/name.h \ + f/intrin.h f/intrin.def f/data.h f/expr.h f/implic.h f/src.h f/st.h $(FLAGS_H) +f/type.o: f/type.c f/proj.h $(ASSERT_H) f/type.h f/malloc.h +f/where.o: f/where.c f/proj.h $(ASSERT_H) f/where.h $(GLIMITS_H) f/top.h f/malloc.h \ + f/lex.h +f/zzz.o: f/zzz.c f/proj.h $(ASSERT_H) f/zzz.h + +# The rest of this list (Fortran 77 language-specific files) is hand-generated. + +f/stamp-str: f/str-1t.h f/str-1t.j f/str-2t.h f/str-2t.j \ + f/str-fo.h f/str-fo.j f/str-io.h f/str-io.j f/str-nq.h f/str-nq.j \ + f/str-op.h f/str-op.j f/str-ot.h f/str-ot.j + touch f/stamp-str + +f/str-1t.h f/str-1t.j: f/fini f/str-1t.fin + ./f/fini `echo $(srcdir)/f/str-1t.fin | sed 's,^\./,,'` f/str-1t.j f/str-1t.h + +f/str-2t.h f/str-2t.j: f/fini f/str-2t.fin + ./f/fini `echo $(srcdir)/f/str-2t.fin | sed 's,^\./,,'` f/str-2t.j f/str-2t.h + +f/str-fo.h f/str-fo.j: f/fini f/str-fo.fin + ./f/fini `echo $(srcdir)/f/str-fo.fin | sed 's,^\./,,'` f/str-fo.j f/str-fo.h + +f/str-io.h f/str-io.j: f/fini f/str-io.fin + ./f/fini `echo $(srcdir)/f/str-io.fin | sed 's,^\./,,'` f/str-io.j f/str-io.h + +f/str-nq.h f/str-nq.j: f/fini f/str-nq.fin + ./f/fini `echo $(srcdir)/f/str-nq.fin | sed 's,^\./,,'` f/str-nq.j f/str-nq.h + +f/str-op.h f/str-op.j: f/fini f/str-op.fin + ./f/fini `echo $(srcdir)/f/str-op.fin | sed 's,^\./,,'` f/str-op.j f/str-op.h + +f/str-ot.h f/str-ot.j: f/fini f/str-ot.fin + ./f/fini `echo $(srcdir)/f/str-ot.fin | sed 's,^\./,,'` f/str-ot.j f/str-ot.h + +f/fini: f/fini.o f/proj-h.o + $(HOST_CC) $(HOST_CFLAGS) -W -Wall $(HOST_LDFLAGS) -o f/fini f/fini.o f/proj-h.o + +f/fini.o: + $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) \ + `echo $(srcdir)/f/fini.c | sed 's,^\./,,'` -o $@ + +f/proj-h.o: f/proj.o + $(HOST_CC) -c $(HOST_CFLAGS) $(HOST_CPPFLAGS) $(INCLUDES) \ + `echo $(srcdir)/f/proj.c | sed 's,^\./,,'` -o $@ + +# Other than str-*.j, the *.j files are dummy #include files +# that normally just #include the corresponding back-end *.h +# files, but not if MAKING_DEPENDENCIES is #defined. The str-*.j +# files also are not actually included if MAKING_DEPENDENCIES +# is #defined. The point of all this is to come up with a clean +# dependencies list whether working in a clean directory, such +# that str-*.j and such do not exist, or in a directory full +# of already-built files. Any dependency on a str-*.j file +# implies a dependency on str.h, so we key on that to replace +# it with stamp-str, and dependencies on the other *.j files +# are generally left alone (modulo special macros like RTL_H) +# because we might not want to recompile all of g77 just +# because a back-end file changes. MG is usually "-MG" but +# should be defined with "make MG= deps-kinda..." if using +# a compiler that doesn't support -MG (gcc does as of 2.6) -- +# it prevents diagnostics when an #include file is missing, +# as will be the case with proj.h in a clean directory. +MG=-MG +deps-kinda: + $(HOST_CC) -DMAKING_DEPENDENCIES -MM $(MG) -I -If f/*.c | \ + sed -e 's: \([.]/\)*f/assert[.]j: $$(ASSERT_H):g' \ + -e 's: \([.]/\)*f/config[.]j: $$(CONFIG_H):g' \ + -e 's: \([.]/\)*f/convert[.]j: $$(CONVERT_H):g' \ + -e 's: \([.]/\)*f/flags[.]j: $$(FLAGS_H):g' \ + -e 's: \([.]/\)*f/glimits[.]j: $$(GLIMITS_H):g' \ + -e 's: \([.]/\)*f/hconfig[.]j: $$(HCONFIG_H):g' \ + -e 's: \([.]/\)*f/input[.]j: $$(INPUT_H):g' \ + -e 's: \([.]/\)*f/rtl[.]j: $$(RTL_H):g' \ + -e 's: \([.]/\)*f/tconfig[.]j: $$(TCONFIG_H):g' \ + -e 's: \([.]/\)*f/tm[.]j: $$(TM_H):g' \ + -e 's: \([.]/\)*f/tree[.]j: $$(TREE_H):g' \ + -e 's: proj[.]h: f/proj.h:g' \ + -e 's: \([.]/\)*f/str[.]h: f/stamp-str:g' \ + -e 's%^\(.*\)[ ]*: %f/\1: %g' + + +# These exist for maintenance purposes. + +# Update the tags table. +TAGS: force + cd $(srcdir)/f ; \ + etags *.c *.h ; \ + echo 'l' | tr 'l' '\f' >> TAGS ; \ + echo 'parse.y,0' >> TAGS ; \ + etags -a ../*.h ../*.c; + +.PHONY: none all all.indirect f77.rebuilt compiler native deps-kinda TAGS g77-only + +force: diff --git a/gcc/f/NEWS b/gcc/f/NEWS new file mode 100644 index 000000000000..40fea330e5d4 --- /dev/null +++ b/gcc/f/NEWS @@ -0,0 +1,1064 @@ +This file lists recent changes to the GNU Fortran compiler. Copyright +(C) 1995, 1996 Free Software Foundation, Inc. You may copy, +distribute, and modify it freely as long as you preserve this copyright +notice and permission notice. + +News About GNU Fortran +********************** + + Changes made to recent versions of GNU Fortran are listed below, +with the most recent version first. + + The changes are generally listed with code-generation bugs first, +followed by compiler crashes involving valid code, new features, fixes +to existing features, new diagnostics, internal improvements, and +miscellany. This order is not strict--for example, some items involve +a combination of these elements. + +In 0.5.21: +========== + + * Fix a code-generation bug introduced by 0.5.20 caused by loop + unrolling (by specifying `-funroll-loops' or similar). This bug + afflicted all code compiled by version 2.7.2.2.f.2 of `gcc' (C, + C++, Fortran, and so on). + + * Fix a code-generation bug manifested when combining local + `EQUIVALENCE' with a `DATA' statement that follows the first + executable statement (or is treated as an executable-context + statement as a result of using the `-fpedantic' option). + + * Fix a compiler crash that occured when an integer division by a + constant zero is detected. Instead, when the `-W' option is + specified, the `gcc' back end issues a warning about such a case. + This bug afflicted all code compiled by version 2.7.2.2.f.2 of + `gcc' (C, C++, Fortran, and so on). + + * Fix a compiler crash that occurred in some cases of procedure + inlining. (Such cases became more frequent in 0.5.20.) + + * Fix a compiler crash resulting from using `DATA' or similar to + initialize a `COMPLEX' variable or array to zero. + + * Fix compiler crashes involving use of `AND', `OR', or `XOR' + intrinsics. + + * Fix compiler bug triggered when using a `COMMON' or `EQUIVALENCE' + variable as the target of an `ASSIGN' or assigned-`GOTO' statement. + + * Fix compiler crashes due to using the name of a some non-standard + intrinsics (such as `FTELL' or `FPUTC') as such and as the name of + a procedure or common block. Such dual use of a name in a program + is allowed by the standard. + + * Place automatic arrays on the stack, even if `SAVE' or the + `-fno-automatic' option is in effect. This avoids a compiler + crash in some cases. + + * New option `-Wno-globals' disables warnings about "suspicious" use + of a name both as a global name and as the implicit name of an + intrinsic, and warnings about disagreements over the number or + natures of arguments passed to global procedures, or the natures + of the procedures themselves. + + The default is to issue such warnings, which are new as of this + version of `g77'. + + * New option `-fno-globals' disables diagnostics about potentially + fatal disagreements analysis problems, such as disagreements over + the number or natures of arguments passed to global procedures, or + the natures of those procedures themselves. + + The default is to issue such diagnostics and flag the compilation + as unsuccessful. With this option, the diagnostics are issued as + warnings, or, if `-Wno-globals' is specified, are not issued at + all. + + This option also disables inlining of global procedures, to avoid + compiler crashes resulting from coding errors that these + diagnostics normally would identify. + + * Diagnose cases where a reference to a procedure disagrees with the + type of that procedure, or where disagreements about the number or + nature of arguments exist. This avoids a compiler crash. + + * Improve performance of the `gcc' back end so certain complicated + expressions involving `COMPLEX' arithmetic (especially + multiplication) don't appear to take forever to compile. + + * Fix a couple of profiling-related bugs in `gcc' back end. + + * Integrate GNU Ada's (GNAT's) changes to the back end, which + consist almost entirely of bug fixes. + + * Include some other `gcc' fixes that seem useful in `g77''s version + of `gcc'. (See `gcc/ChangeLog' for details--compare it to that + file in the vanilla `gcc-2.7.2.2.tar.gz' distribution.) + + * Fix `libU77' routines that accept file and other names to strip + trailing blanks from them, for consistency with other + implementations. Blanks may be forcibly appended to such names by + appending a single null character (`CHAR(0)') to the significant + trailing blanks. + + * Fix `CHMOD' intrinsic to work with file names that have embedded + blanks, commas, and so on. + + * Fix `SIGNAL' intrinsic so it accepts an optional third `Status' + argument. + + * Fix `IDATE()' intrinsic subroutine (VXT form) so it accepts + arguments in the correct order. Documentation fixed accordingly, + and for `GMTIME()' and `LTIME()' as well. + + * Make many changes to `libU77' intrinsics to support existing code + more directly. + + Such changes include allowing both subroutine and function forms + of many routines, changing `MCLOCK()' and `TIME()' to return + `INTEGER(KIND=1)' values, introducing `MCLOCK8()' and `TIME8()' to + return `INTEGER(KIND=2)' values, and placing functions that are + intended to perform side effects in a new intrinsic group, + `badu77'. + + * Improve `libU77' so it is more portable. + + * Add options `-fbadu77-intrinsics-delete', + `-fbadu77-intrinsics-hide', and so on. + + * Fix crashes involving diagnosed or invalid code. + + * `g77' and `gcc' now do a somewhat better job detecting and + diagnosing arrays that are too large to handle before these cause + diagnostics during the assembler or linker phase, a compiler + crash, or generation of incorrect code. + + * Improve alias analysis code to properly handle output registers + (such as the `%o' registers on the SPARC). + + * Add support for `restrict' keyword in `gcc' front end. + + * Modify `make' rules and related code so that generation of Info + documentation doesn't require compilation using `gcc'. + + * Add `INT2' and `INT8' intrinsics. + + * Add `CPU_TIME' intrinsic. + + * Add `ALARM' intrinsic. + + * `CTIME' intrinsic now accepts any `INTEGER' argument, not just + `INTEGER(KIND=2)'. + + * Warn when explicit type declaration disagrees with the type of an + intrinsic invocation. + + * Support `*f771' entry in `gcc' `specs' file. + + * Fix typo in `make' rule `g77-cross', used only for cross-compiling. + + * Fix `libf2c' build procedure to re-archive library if previous + attempt to archive was interrupted. + + * Fix `gcc' to more easily support configuring on Pentium Pro (686) + systems. + + * Change `gcc' to unroll loops only during the last invocation (of + as many as two invocations) of loop optimization. + + * Improve handling of `-fno-f2c' so that code that attempts to pass + an intrinsic as an actual argument, such as `CALL FOO(ABS)', is + rejected due to the fact that the run-time-library routine is, + effectively, compiled with `-ff2c' in effect. + + * Fix `g77' driver to recognize `-fsyntax-only' as an option that + inhibits linking, just like `-c' or `-S', and to recognize and + properly handle the `-nostdlib', `-M', `-MM', `-nodefaultlibs', + and `-Xlinker' options. + + * Upgrade to `libf2c' as of 1997-08-06. + + * Modify `libf2c' to consistently and clearly diagnose recursive I/O + (at run time). + + * `g77' driver now prints version information (such as produced by + `g77 -v') to `stderr' instead of `stdout'. + + * The `.r' suffix now designates a Ratfor source file, to be + preprocessed via the `ratfor' command, available separately. + + * Fix some aspects of how `gcc' determines what kind of system is + being configured and what kinds are supported. For example, GNU + Linux/Alpha ELF systems now are directly supported. + + * Improve diagnostics. + + * Improve documentation and indexing. + + * Include all pertinent files for `libf2c' that come from + `netlib.bell-labs.com'; give any such files that aren't quite + accurate in `g77''s version of `libf2c' the suffix `.netlib'. + + * Reserve `INTEGER(KIND=0)' for future use. + +In 0.5.20: +========== + + * The `-fno-typeless-boz' option is now the default. + + This option specifies that non-decimal-radix constants using the + prefixed-radix form (such as `Z'1234'') are to be interpreted as + `INTEGER' constants. Specify `-ftypeless-boz' to cause such + constants to be interpreted as typeless. + + (Version 0.5.19 introduced `-fno-typeless-boz' and its inverse.) + + * Options `-ff90-intrinsics-enable' and `-fvxt-intrinsics-enable' + now are the defaults. + + Some programs might use names that clash with intrinsic names + defined (and now enabled) by these options or by the new `libU77' + intrinsics. Users of such programs might need to compile them + differently (using, for example, `-ff90-intrinsics-disable') or, + better yet, insert appropriate `EXTERNAL' statements specifying + that these names are not intended to be names of intrinsics. + + * The `ALWAYS_FLUSH' macro is no longer defined when building + `libf2c', which should result in improved I/O performance, + especially over NFS. + + *Note:* If you have code that depends on the behavior of `libf2c' + when built with `ALWAYS_FLUSH' defined, you will have to modify + `libf2c' accordingly before building it from this and future + versions of `g77'. + + * Dave Love's implementation of `libU77' has been added to the + version of `libf2c' distributed with and built as part of `g77'. + `g77' now knows about the routines in this library as intrinsics. + + * New option `-fvxt' specifies that the source file is written in + VXT Fortran, instead of GNU Fortran. + + * The `-fvxt-not-f90' option has been deleted, along with its + inverse, `-ff90-not-vxt'. + + If you used one of these deleted options, you should re-read the + pertinent documentation to determine which options, if any, are + appropriate for compiling your code with this version of `g77'. + + * The `-fugly' option now issues a warning, as it likely will be + removed in a future version. + + (Enabling all the `-fugly-*' options is unlikely to be feasible, + or sensible, in the future, so users should learn to specify only + those `-fugly-*' options they really need for a particular source + file.) + + * The `-fugly-assumed' option, introduced in version 0.5.19, has + been changed to better accommodate old and new code. + + * Make a number of fixes to the `g77' front end and the `gcc' back + end to better support Alpha (AXP) machines. This includes + providing at least one bug-fix to the `gcc' back end for Alphas. + + * Related to supporting Alpha (AXP) machines, the `LOC()' intrinsic + and `%LOC()' construct now return values of integer type that is + the same width (holds the same number of bits) as the pointer type + on the machine. + + On most machines, this won't make a difference, whereas on Alphas, + the type these constructs return is `INTEGER*8' instead of the + more common `INTEGER*4'. + + * Emulate `COMPLEX' arithmetic in the `g77' front end, to avoid bugs + in `complex' support in the `gcc' back end. New option + `-fno-emulate-complex' causes `g77' to revert the 0.5.19 behavior. + + * Fix bug whereby `REAL A(1)', for example, caused a compiler crash + if `-fugly-assumed' was in effect and A was a local (automatic) + array. That case is no longer affected by the new handling of + `-fugly-assumed'. + + * Fix `g77' command driver so that `g77 -o foo.f' no longer deletes + `foo.f' before issuing other diagnostics, and so the `-x' option + is properly handled. + + * Enable inlining of subroutines and functions by the `gcc' back end. + This works as it does for `gcc' itself--program units may be + inlined for invocations that follow them in the same program unit, + as long as the appropriate compile-time options are specified. + + * Dummy arguments are no longer assumed to potentially alias + (overlap) other dummy arguments or `COMMON' areas when any of + these are defined (assigned to) by Fortran code. + + This can result in faster and/or smaller programs when compiling + with optimization enabled, though on some systems this effect is + observed only when `-fforce-addr' also is specified. + + New options `-falias-check', `-fargument-alias', + `-fargument-noalias', and `-fno-argument-noalias-global' control + the way `g77' handles potential aliasing. + + * The `CONJG()' and `DCONJG()' intrinsics now are compiled in-line. + + * The bug-fix for 0.5.19.1 has been re-done. The `g77' compiler has + been changed back to assume `libf2c' has no aliasing problems in + its implementations of the `COMPLEX' (and `DOUBLE COMPLEX') + intrinsics. The `libf2c' has been changed to have no such + problems. + + As a result, 0.5.20 is expected to offer improved performance over + 0.5.19.1, perhaps as good as 0.5.19 in most or all cases, due to + this change alone. + + *Note:* This change requires version 0.5.20 of `libf2c', at least, + when linking code produced by any versions of `g77' other than + 0.5.19.1. Use `g77 -v' to determine the version numbers of the + `libF77', `libI77', and `libU77' components of the `libf2c' + library. (If these version numbers are not printed--in + particular, if the linker complains about unresolved references to + names like `g77__fvers__'--that strongly suggests your + installation has an obsolete version of `libf2c'.) + + * New option `-fugly-assign' specifies that the same memory + locations are to be used to hold the values assigned by both + statements `I = 3' and `ASSIGN 10 TO I', for example. (Normally, + `g77' uses a separate memory location to hold assigned statement + labels.) + + * `FORMAT' and `ENTRY' statements now are allowed to precede + `IMPLICIT NONE' statements. + + * Produce diagnostic for unsupported `SELECT CASE' on `CHARACTER' + type, instead of crashing, at compile time. + + * Fix crashes involving diagnosed or invalid code. + + * Change approach to building `libf2c' archive (`libf2c.a') so that + members are added to it only when truly necessary, so the user + that installs an already-built `g77' doesn't need to have write + access to the build tree (whereas the user doing the build might + not have access to install new software on the system). + + * Support `gcc' version 2.7.2.2 (modified by `g77' into version + 2.7.2.2.f.2), and remove support for prior versions of `gcc'. + + * Upgrade to `libf2c' as of 1997-02-08, and fix up some of the build + procedures. + + * Improve general build procedures for `g77', fixing minor bugs + (such as deletion of any file named `f771' in the parent directory + of `gcc/'). + + * Enable full support of `INTEGER*8' available in `libf2c' and + `f2c.h' so that `f2c' users may make full use of its features via + the `g77' version of `f2c.h' and the `INTEGER*8' support routines + in the `g77' version of `libf2c'. + + * Improve `g77' driver and `libf2c' so that `g77 -v' yields version + information on the library. + + * The `SNGL' and `FLOAT' intrinsics now are specific intrinsics, + instead of synonyms for the generic intrinsic `REAL'. + + * New intrinsics have been added. These are `REALPART', `IMAGPART', + `COMPLEX', `LONG', and `SHORT'. + + * A new group of intrinsics, `gnu', has been added to contain the + new `REALPART', `IMAGPART', and `COMPLEX' intrinsics. An old + group, `dcp', has been removed. + + * Complain about industry-wide ambiguous references `REAL(EXPR)' and + `AIMAG(EXPR)', where EXPR is `DOUBLE COMPLEX' (or any complex type + other than `COMPLEX'), unless `-ff90' option specifies Fortran 90 + interpretation or new `-fugly-complex' option, in conjunction with + `-fnot-f90', specifies `f2c' interpretation. + + * Make improvements to diagnostics. + + * Speed up compiler a bit. + + * Improvements to documentation and indexing, including a new + chapter containing information on one, later more, diagnostics + that users are directed to pull up automatically via a message in + the diagnostic itself. + + (Hence the menu item `M' for the node `Diagnostics' in the + top-level menu of the Info documentation.) + +In 0.5.19.1: +============ + + * Code-generation bugs afflicting operations on complex data have + been fixed. + + These bugs occurred when assigning the result of an operation to a + complex variable (or array element) that also served as an input + to that operation. + + The operations affected by this bug were: `CONJG()', `DCONJG()', + `CCOS()', `CDCOS()', `CLOG()', `CDLOG()', `CSIN()', `CDSIN()', + `CSQRT()', `CDSQRT()', complex division, and raising a `DOUBLE + COMPLEX' operand to an `INTEGER' power. (The related generic and + `Z'-prefixed intrinsics, such as `ZSIN()', also were affected.) + + For example, `C = CSQRT(C)', `Z = Z/C', and `Z = Z**I' (where `C' + is `COMPLEX' and `Z' is `DOUBLE COMPLEX') have been fixed. + +In 0.5.19: +========== + + * Fix `FORMAT' statement parsing so negative values for specifiers + such as `P' (e.g. `FORMAT(-1PF8.1)') are correctly processed as + negative. + + * Fix `SIGNAL' intrinsic so it once again accepts a procedure as its + second argument. + + * A temporary kludge option provides bare-bones information on + `COMMON' and `EQUIVALENCE' members at debug time. + + * New `-fonetrip' option specifies FORTRAN-66-style one-trip `DO' + loops. + + * New `-fno-silent' option causes names of program units to be + printed as they are compiled, in a fashion similar to UNIX `f77' + and `f2c'. + + * New `-fugly-assumed' option specifies that arrays dimensioned via + `DIMENSION X(1)', for example, are to be treated as assumed-size. + + * New `-fno-typeless-boz' option specifies that non-decimal-radix + constants using the prefixed-radix form (such as `Z'1234'') are to + be interpreted as `INTEGER' constants. + + * New `-ff66' option is a "shorthand" option that specifies + behaviors considered appropriate for FORTRAN 66 programs. + + * New `-ff77' option is a "shorthand" option that specifies + behaviors considered appropriate for UNIX `f77' programs. + + * New `-fugly-comma' and `-fugly-logint' options provided to perform + some of what `-fugly' used to do. `-fugly' and `-fno-ugly' are + now "shorthand" options, in that they do nothing more than enable + (or disable) other `-fugly-*' options. + + * Fix parsing of assignment statements involving targets that are + substrings of elements of `CHARACTER' arrays having names such as + `READ', `WRITE', `GOTO', and `REALFUNCTIONFOO'. + + * Fix crashes involving diagnosed code. + + * Fix handling of local `EQUIVALENCE' areas so certain cases of + valid Fortran programs are not misdiagnosed as improperly + extending the area backwards. + + * Support `gcc' version 2.7.2.1. + + * Upgrade to `libf2c' as of 1996-09-26, and fix up some of the build + procedures. + + * Change code generation for list-directed I/O so it allows for new + versions of `libf2c' that might return non-zero status codes for + some operations previously assumed to always return zero. + + This change not only affects how `IOSTAT=' variables are set by + list-directed I/O, it also affects whether `END=' and `ERR=' + labels are reached by these operations. + + * Add intrinsic support for new `FTELL' and `FSEEK' procedures in + `libf2c'. + + * Modify `fseek_()' in `libf2c' to be more portable (though, in + practice, there might be no systems where this matters) and to + catch invalid `whence' arguments. + + * Some useless warnings from the `-Wunused' option have been + eliminated. + + * Fix a problem building the `f771' executable on AIX systems by + linking with the `-bbigtoc' option. + + * Abort configuration if `gcc' has not been patched using the patch + file provided in the `gcc/f/gbe/' subdirectory. + + * Add options `--help' and `--version' to the `g77' command, to + conform to GNU coding guidelines. Also add printing of `g77' + version number when the `--verbose' (`-v') option is used. + + * Change internally generated name for local `EQUIVALENCE' areas to + one based on the alphabetically sorted first name in the list of + names for entities placed at the beginning of the areas. + + * Improvements to documentation and indexing. + +In 0.5.18: +========== + + * Add some rudimentary support for `INTEGER*1', `INTEGER*2', + `INTEGER*8', and their `LOGICAL' equivalents. (This support works + on most, maybe all, `gcc' targets.) + + Thanks to Scott Snyder () for providing + the patch for this! + + Among the missing elements from the support for these features are + full intrinsic support and constants. + + * Add some rudimentary support for the `BYTE' and `WORD' + type-declaration statements. `BYTE' corresponds to `INTEGER*1', + while `WORD' corresponds to `INTEGER*2'. + + Thanks to Scott Snyder () for providing + the patch for this! + + * The compiler code handling intrinsics has been largely rewritten + to accommodate the new types. No new intrinsics or arguments for + existing intrinsics have been added, so there is, at this point, + no intrinsic to convert to `INTEGER*8', for example. + + * Support automatic arrays in procedures. + + * Reduce space/time requirements for handling large *sparsely* + initialized aggregate arrays. This improvement applies to only a + subset of the general problem to be addressed in 0.6. + + * Treat initial values of zero as if they weren't specified (in DATA + and type-declaration statements). The initial values will be set + to zero anyway, but the amount of compile time processing them + will be reduced, in some cases significantly (though, again, this + is only a subset of the general problem to be addressed in 0.6). + + A new option, `-fzeros', is introduced to enable the traditional + treatment of zeros as any other value. + + * With `-ff90' in force, `g77' incorrectly interpreted `REAL(Z)' as + returning a `REAL' result, instead of as a `DOUBLE PRECISION' + result. (Here, `Z' is `DOUBLE COMPLEX'.) + + With `-fno-f90' in force, the interpretation remains unchanged, + since this appears to be how at least some F77 code using the + `DOUBLE COMPLEX' extension expected it to work. + + Essentially, `REAL(Z)' in F90 is the same as `DBLE(Z)', while in + extended F77, it appears to be the same as `REAL(REAL(Z))'. + + * An expression involving exponentiation, where both operands were + type `INTEGER' and the right-hand operand was negative, was + erroneously evaluated. + + * Fix bugs involving `DATA' implied-`DO' constructs (these involved + an errant diagnostic and a crash, both on good code, one involving + subsequent statement-function definition). + + * Close `INCLUDE' files after processing them, so compiling source + files with lots of `INCLUDE' statements does not result in being + unable to open `INCLUDE' files after all the available file + descriptors are used up. + + * Speed up compiling, especially of larger programs, and perhaps + slightly reduce memory utilization while compiling (this is *not* + the improvement planned for 0.6 involving large aggregate + areas)--these improvements result from simply turning off some + low-level code to do self-checking that hasn't been triggered in a + long time. + + * Introduce three new options that implement optimizations in the + `gcc' back end (GBE). These options are `-fmove-all-movables', + `-freduce-all-givs', and `-frerun-loop-opt', which are enabled, by + default, for Fortran compilations. These optimizations are + intended to help toon Fortran programs. + + * Patch the GBE to do a better job optimizing certain kinds of + references to array elements. + + * Due to patches to the GBE, the version number of `gcc' also is + patched to make it easier to manage installations, especially + useful if it turns out a `g77' change to the GBE has a bug. + + The `g77'-modified version number is the `gcc' version number with + the string `.f.N' appended, where `f' identifies the version as + enhanced for Fortran, and N is `1' for the first Fortran patch for + that version of `gcc', `2' for the second, and so on. + + So, this introduces version 2.7.2.f.1 of `gcc'. + + * Make several improvements and fixes to diagnostics, including the + removal of two that were inappropriate or inadequate. + + * Warning about two successive arithmetic operators, produced by + `-Wsurprising', now produced *only* when both operators are, + indeed, arithmetic (not relational/boolean). + + * `-Wsurprising' now warns about the remaining cases of using + non-integral variables for implied-`DO' loops, instead of these + being rejected unless `-fpedantic' or `-fugly' specified. + + * Allow `SAVE' of a local variable or array, even after it has been + given an initial value via `DATA', for example. + + * Introduce an Info version of `g77' documentation, which supercedes + `gcc/f/CREDITS', `gcc/f/DOC', and `gcc/f/PROJECTS'. These files + will be removed in a future release. The files `gcc/f/BUGS', + `gcc/f/INSTALL', and `gcc/f/NEWS' now are automatically built from + the texinfo source when distributions are made. + + This effort was inspired by a first pass at translating + `g77-0.5.16/f/DOC' that was contributed to Craig by David Ronis + (). + + * New `-fno-second-underscore' option to specify that, when + `-funderscoring' is in effect, a second underscore is not to be + appended to Fortran names already containing an underscore. + + * Change the way iterative `DO' loops work to follow the F90 + standard. In particular, calculation of the iteration count is + still done by converting the start, end, and increment parameters + to the type of the `DO' variable, but the result of the + calculation is always converted to the default `INTEGER' type. + + (This should have no effect on existing code compiled by `g77', + but code written to assume that use of a *wider* type for the `DO' + variable will result in an iteration count being fully calculated + using that wider type (wider than default `INTEGER') must be + rewritten.) + + * Support `gcc' version 2.7.2. + + * Upgrade to `libf2c' as of 1996-03-23, and fix up some of the build + procedures. + + Note that the email addresses related to `f2c' have changed--the + distribution site now is named `netlib.bell-labs.com', and the + maintainer's new address is . + +In 0.5.17: +========== + + * *Fix serious bug* in `g77 -v' command that can cause removal of a + system's `/dev/null' special file if run by user `root'. + + *All users* of version 0.5.16 should ensure that they have not + removed `/dev/null' or replaced it with an ordinary file (e.g. by + comparing the output of `ls -l /dev/null' with `ls -l /dev/zero'. + If the output isn't basically the same, contact your system + administrator about restoring `/dev/null' to its proper status). + + This bug is particularly insidious because removing `/dev/null' as + a special file can go undetected for quite a while, aside from + various applications and programs exhibiting sudden, strange + behaviors. + + I sincerely apologize for not realizing the implications of the + fact that when `g77 -v' runs the `ld' command with `-o /dev/null' + that `ld' tries to *remove* the executable it is supposed to build + (especially if it reports unresolved references, which it should + in this case)! + + * Fix crash on `CHARACTER*(*) FOO' in a main or block data program + unit. + + * Fix crash that can occur when diagnostics given outside of any + program unit (such as when input file contains `@foo'). + + * Fix crashes, infinite loops (hangs), and such involving diagnosed + code. + + * Fix `ASSIGN''ed variables so they can be `SAVE''d or dummy + arguments, and issue clearer error message in cases where target + of `ASSIGN' or `ASSIGN'ed `GOTO'/`FORMAT' is too small (which + should never happen). + + * Make `libf2c' build procedures work on more systems again by + eliminating unnecessary invocations of `ld -r -x' and `mv'. + + * Fix omission of `-funix-intrinsics-...' options in list of + permitted options to compiler. + + * Fix failure to always diagnose missing type declaration for + `IMPLICIT NONE'. + + * Fix compile-time performance problem (which could sometimes crash + the compiler, cause a hang, or whatever, due to a bug in the back + end) involving exponentiation with a large `INTEGER' constant for + the right-hand operator (e.g. `I**32767'). + + * Fix build procedures so cross-compiling `g77' (the `fini' utility + in particular) is properly built using the host compiler. + + * Add new `-Wsurprising' option to warn about constructs that are + interpreted by the Fortran standard (and `g77') in ways that are + surprising to many programmers. + + * Add `ERF()' and `ERFC()' as generic intrinsics mapping to existing + `ERF'/`DERF' and `ERFC'/`DERFC' specific intrinsics. + + *Note:* You should specify `INTRINSIC ERF,ERFC' in any code where + you might use these as generic intrinsics, to improve likelihood + of diagnostics (instead of subtle run-time bugs) when using a + compiler that doesn't support these as intrinsics (e.g. `f2c'). + + * Remove from `-fno-pedantic' the diagnostic about `DO' with + non-`INTEGER' index variable; issue that under `-Wsurprising' + instead. + + * Clarify some diagnostics that say things like "ignored" when that's + misleading. + + * Clarify diagnostic on use of `.EQ.'/`.NE.' on `LOGICAL' operands. + + * Minor improvements to code generation for various operations on + `LOGICAL' operands. + + * Minor improvement to code generation for some `DO' loops on some + machines. + + * Support `gcc' version 2.7.1. + + * Upgrade to `libf2c' as of 1995-11-15. + +In 0.5.16: +========== + + * Fix a code-generation bug involving complicated `EQUIVALENCE' + statements not involving `COMMON'. + + * Fix code-generation bugs involving invoking "gratis" library + procedures in `libf2c' from code compiled with `-fno-f2c' by + making these procedures known to `g77' as intrinsics (not affected + by -fno-f2c). This is known to fix code invoking `ERF()', + `ERFC()', `DERF()', and `DERFC()'. + + * Update `libf2c' to include netlib patches through 1995-08-16, and + `#define' `WANT_LEAD_0' to 1 to make `g77'-compiled code more + consistent with other Fortran implementations by outputting + leading zeros in formatted and list-directed output. + + * Fix a code-generation bug involving adjustable dummy arrays with + high bounds whose primaries are changed during procedure + execution, and which might well improve code-generation + performance for such arrays compared to `f2c' plus `gcc' (but + apparently only when using `gcc-2.7.0' or later). + + * Fix a code-generation bug involving invocation of `COMPLEX' and + `DOUBLE COMPLEX' `FUNCTION's and doing `COMPLEX' and `DOUBLE + COMPLEX' divides, when the result of the invocation or divide is + assigned directly to a variable that overlaps one or more of the + arguments to the invocation or divide. + + * Fix crash by not generating new optimal code for `X**I' if `I' is + nonconstant and the expression is used to dimension a dummy array, + since the `gcc' back end does not support the necessary mechanics + (and the `gcc' front end rejects the equivalent construct, as it + turns out). + + * Fix crash on expressions like `COMPLEX**INTEGER'. + + * Fix crash on expressions like `(1D0,2D0)**2', i.e. raising a + `DOUBLE COMPLEX' constant to an `INTEGER' constant power. + + * Fix crashes and such involving diagnosed code. + + * Diagnose, instead of crashing on, statement function definitions + having duplicate dummy argument names. + + * Fix bug causing rejection of good code involving statement function + definitions. + + * Fix bug resulting in debugger not knowing size of local equivalence + area when any member of area has initial value (via `DATA', for + example). + + * Fix installation bug that prevented installation of `g77' driver. + Provide for easy selection of whether to install copy of `g77' as + `f77' to replace the broken code. + + * Fix `gcc' driver (affects `g77' thereby) to not gratuitously + invoke the `f771' program (e.g. when `-E' is specified). + + * Fix diagnostic to point to correct source line when it immediately + follows an `INCLUDE' statement. + + * Support more compiler options in `gcc'/`g77' when compiling + Fortran files. These options include `-p', `-pg', `-aux-info', + `-P', correct setting of version-number macros for preprocessing, + full recognition of `-O0', and automatic insertion of + configuration-specific linker specs. + + * Add new intrinsics that interface to existing routines in `libf2c': + `ABORT', `DERF', `DERFC', `ERF', `ERFC', `EXIT', `FLUSH', + `GETARG', `GETENV', `IARGC', `SIGNAL', and `SYSTEM'. Note that + `ABORT', `EXIT', `FLUSH', `SIGNAL', and `SYSTEM' are intrinsic + subroutines, not functions (since they have side effects), so to + get the return values from `SIGNAL' and `SYSTEM', append a final + argument specifying an `INTEGER' variable or array element (e.g. + `CALL SYSTEM('rm foo',ISTAT)'). + + * Add new intrinsic group named `unix' to contain the new intrinsics, + and by default enable this new group. + + * Move `LOC()' intrinsic out of the `vxt' group to the new `unix' + group. + + * Improve `g77' so that `g77 -v' by itself (or with certain other + options, including `-B', `-b', `-i', `-nostdlib', and `-V') + reports lots more useful version info, and so that long-form + options `gcc' accepts are understood by `g77' as well (even in + truncated, unambiguous forms). + + * Add new `g77' option `--driver=name' to specify driver when + default, `gcc', isn't appropriate. + + * Add support for `#' directives (as output by the preprocessor) in + the compiler, and enable generation of those directives by the + preprocessor (when compiling `.F' files) so diagnostics and + debugging info are more useful to users of the preprocessor. + + * Produce better diagnostics, more like `gcc', with info such as `In + function `foo':' and `In file included from...:'. + + * Support `gcc''s `-fident' and `-fno-ident' options. + + * When `-Wunused' in effect, don't warn about local variables used as + statement-function dummy arguments or `DATA' implied-`DO' iteration + variables, even though, strictly speaking, these are not uses of + the variables themselves. + + * When `-W -Wunused' in effect, don't warn about unused dummy + arguments at all, since there's no way to turn this off for + individual cases (`g77' might someday start warning about + these)--applies to `gcc' versions 2.7.0 and later, since earlier + versions didn't warn about unused dummy arguments. + + * New option `-fno-underscoring' that inhibits transformation of + names (by appending one or two underscores) so users may experiment + with implications of such an environment. + + * Minor improvement to `gcc/f/info' module to make it easier to build + `g77' using the native (non-`gcc') compiler on certain machines + (but definitely not all machines nor all non-`gcc' compilers). + Please do not report bugs showing problems compilers have with + macros defined in `gcc/f/target.h' and used in places like + `gcc/f/expr.c'. + + * Add warning to be printed for each invocation of the compiler if + the target machine `INTEGER', `REAL', or `LOGICAL' size is not 32 + bits, since `g77' is known to not work well for such cases (to be + fixed in Version 0.6--*note Actual Bugs We Haven't Fixed Yet: + Actual Bugs.). + + * Lots of new documentation (though work is still needed to put it + into canonical GNU format). + + * Build `libf2c' with `-g0', not `-g2', in effect (by default), to + produce smaller library without lots of debugging clutter. + +In 0.5.15: +========== + + * Fix bad code generation involving `X**I' and temporary, internal + variables generated by `g77' and the back end (such as for `DO' + loops). + + * Fix crash given `CHARACTER A;DATA A/.TRUE./'. + + * Replace crash with diagnostic given `CHARACTER A;DATA A/1.0/'. + + * Fix crash or other erratic behavior when null character constant + (`''') is encountered. + + * Fix crash or other erratic behavior involving diagnosed code. + + * Fix code generation for external functions returning type `REAL' + when the `-ff2c' option is in force (which it is by default) so + that `f2c' compatibility is indeed provided. + + * Disallow `COMMON I(10)' if `I' has previously been specified with + an array declarator. + + * New `-ffixed-line-length-N' option, where N is the maximum length + of a typical fixed-form line, defaulting to 72 columns, such that + characters beyond column N are ignored, or N is `none', meaning no + characters are ignored. does not affect lines with `&' in column + 1, which are always processed as if `-ffixed-line-length-none' was + in effect. + + * No longer generate better code for some kinds of array references, + as `gcc' back end is to be fixed to do this even better, and it + turned out to slow down some code in some cases after all. + + * In `COMMON' and `EQUIVALENCE' areas with any members given initial + values (e.g. via `DATA'), uninitialized members now always + initialized to binary zeros (though this is not required by the + standard, and might not be done in future versions of `g77'). + Previously, in some `COMMON'/`EQUIVALENCE' areas (essentially + those with members of more than one type), the uninitialized + members were initialized to spaces, to cater to `CHARACTER' types, + but it seems no existing code expects that, while much existing + code expects binary zeros. + +In 0.5.14: +========== + + * Don't emit bad code when low bound of adjustable array is + nonconstant and thus might vary as an expression at run time. + + * Emit correct code for calculation of number of trips in `DO' loops + for cases where the loop should not execute at all. (This bug + affected cases where the difference between the begin and end + values was less than the step count, though probably not for + floating-point cases.) + + * Fix crash when extra parentheses surround item in `DATA' + implied-`DO' list. + + * Fix crash over minor internal inconsistencies in handling + diagnostics, just substitute dummy strings where necessary. + + * Fix crash on some systems when compiling call to `MVBITS()' + intrinsic. + + * Fix crash on array assignment `TYPEDDD(...)=...', where DDD is a + string of one or more digits. + + * Fix crash on `DCMPLX()' with a single `INTEGER' argument. + + * Fix various crashes involving code with diagnosed errors. + + * Support `-I' option for `INCLUDE' statement, plus `gcc''s + `header.gcc' facility for handling systems like MS-DOS. + + * Allow `INCLUDE' statement to be continued across multiple lines, + even allow it to coexist with other statements on the same line. + + * Incorporate Bellcore fixes to `libf2c' through 1995-03-15--this + fixes a bug involving infinite loops reading EOF with empty + list-directed I/O list. + + * Remove all the `g77'-specific auto-configuration scripts, code, + and so on, except for temporary substitutes for bsearch() and + strtoul(), as too many configure/build problems were reported in + these areas. People will have to fix their systems' problems + themselves, or at least somewhere other than `g77', which expects + a working ANSI C environment (and, for now, a GNU C compiler to + compile `g77' itself). + + * Complain if initialized common redeclared as larger in subsequent + program unit. + + * Warn if blank common initialized, since its size can vary and hence + related warnings that might be helpful won't be seen. + + * New `-fbackslash' option, on by default, that causes `\' within + `CHARACTER' and Hollerith constants to be interpreted a la GNU C. + Note that this behavior is somewhat different from `f2c''s, which + supports only a limited subset of backslash (escape) sequences. + + * Make `-fugly-args' the default. + + * New `-fugly-init' option, on by default, that allows + typeless/Hollerith to be specified as initial values for variables + or named constants (`PARAMETER'), and also allows + character<->numeric conversion in those contexts--turn off via + `-fno-ugly-init'. + + * New `-finit-local-zero' option to initialize local variables to + binary zeros. This does not affect whether they are `SAVE'd, i.e. + made automatic or static. + + * New `-Wimplicit' option to warn about implicitly typed variables, + arrays, and functions. (Basically causes all program units to + default to `IMPLICIT NONE'.) + + * `-Wall' now implies `-Wuninitialized' as with `gcc' (i.e. unless + `-O' not specified, since `-Wuninitialized' requires `-O'), and + implies `-Wunused' as well. + + * `-Wunused' no longer gives spurious messages for unused `EXTERNAL' + names (since they are assumed to refer to block data program + units, to make use of libraries more reliable). + + * Support `%LOC()' and `LOC()' of character arguments. + + * Support null (zero-length) character constants and expressions. + + * Support `f2c''s `IMAG()' generic intrinsic. + + * Support `ICHAR()', `IACHAR()', and `LEN()' of character + expressions that are valid in assignments but not normally as + actual arguments. + + * Support `f2c'-style `&' in column 1 to mean continuation line. + + * Allow `NAMELIST', `EXTERNAL', `INTRINSIC', and `VOLATILE' in + `BLOCK DATA', even though these are not allowed by the standard. + + * Allow `RETURN' in main program unit. + + * Changes to Hollerith-constant support to obey Appendix C of the + standard: + + - Now padded on the right with zeros, not spaces. + + - Hollerith "format specifications" in the form of arrays of + non-character allowed. + + - Warnings issued when non-space truncation occurs when + converting to another type. + + - When specified as actual argument, now passed by reference to + `INTEGER' (padded on right with spaces if constant too small, + otherwise fully intact if constant wider the `INTEGER' type) + instead of by value. + + *Warning:* `f2c' differs on the interpretation of `CALL FOO(1HX)', + which it treats exactly the same as `CALL FOO('X')', but which the + standard and `g77' treat as `CALL FOO(%REF('X '))' (padded with + as many spaces as necessary to widen to `INTEGER'), essentially. + + * Changes and fixes to typeless-constant support: + + - Now treated as a typeless double-length `INTEGER' value. + + - Warnings issued when overflow occurs. + + - Padded on the left with zeros when converting to a larger + type. + + - Should be properly aligned and ordered on the target machine + for whatever type it is turned into. + + - When specified as actual argument, now passed as reference to + a default `INTEGER' constant. + + * `%DESCR()' of a non-`CHARACTER' expression now passes a pointer to + the expression plus a length for the expression just as if it were + a `CHARACTER' expression. For example, `CALL FOO(%DESCR(D))', + where `D' is `REAL*8', is the same as `CALL FOO(D,%VAL(8)))'. + + * Name of multi-entrypoint master function changed to incorporate + the name of the primary entry point instead of a decimal value, so + the name of the master function for `SUBROUTINE X' with alternate + entry points is now `__g77_masterfun_x'. + + * Remove redundant message about zero-step-count `DO' loops. + + * Clean up diagnostic messages, shortening many of them. + + * Fix typo in `g77' man page. + + * Clarify implications of constant-handling bugs in `f/BUGS'. + + * Generate better code for `**' operator with a right-hand operand of + type `INTEGER'. + + * Generate better code for `SQRT()' and `DSQRT()', also when + `-ffast-math' specified, enable better code generation for `SIN()' + and `COS()'. + + * Generate better code for some kinds of array references. + + * Speed up lexing somewhat (this makes the compilation phase + noticeably faster). + diff --git a/gcc/f/README b/gcc/f/README new file mode 100644 index 000000000000..fdebfdca1763 --- /dev/null +++ b/gcc/f/README @@ -0,0 +1,7 @@ +1995-02-15 + +This directory is the f/ subdirectory, which is designed to +be a subdirectory in a gcc development tree, i.e. named gcc/f/. + +Please see gcc/README.g77 for information on the contents of this +directory. diff --git a/gcc/f/assert.j b/gcc/f/assert.j new file mode 100644 index 000000000000..fe95676ea53f --- /dev/null +++ b/gcc/f/assert.j @@ -0,0 +1,27 @@ +/* assert.j -- Wrapper for GCC's assert.h + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. */ + +#ifndef MAKING_DEPENDENCIES +#ifndef _J_f_assert +#define _J_f_assert +#include "assert.h" +#endif +#endif diff --git a/gcc/f/bad.c b/gcc/f/bad.c new file mode 100644 index 000000000000..3db782f92595 --- /dev/null +++ b/gcc/f/bad.c @@ -0,0 +1,543 @@ +/* bad.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + None + + Description: + Handles the displaying of diagnostic messages regarding the user's source + files. + + Modifications: +*/ + +/* If there's a %E or %4 in the messages, set this to at least 5, + for example. */ + +#define FFEBAD_MAX_ 6 + +/* Include files. */ + +#include "proj.h" +#include +#include "bad.h" +#include "com.h" +#include "where.h" + +/* Externals defined here. */ + +bool ffebad_is_inhibited_ = FALSE; + +/* Simple definitions and enumerations. */ + +#define FFEBAD_LONG_MSGS_ 1 /* 0 to use short (or same) messages. */ + +/* Internal typedefs. */ + + +/* Private include files. */ + + +/* Internal structure definitions. */ + +struct _ffebad_message_ + { + ffebadSeverity severity; + char *message; + }; + +/* Static objects accessed by functions in this module. */ + +static struct _ffebad_message_ ffebad_messages_[] += +{ +#define FFEBAD_MSGS1(KWD,SEV,MSG) { SEV, MSG }, +#if FFEBAD_LONG_MSGS_ == 0 +#define FFEBAD_MSGS2(KWD,SEV,LMSG,SMSG) { SEV, SMSG }, +#else +#define FFEBAD_MSGS2(KWD,SEV,LMSG,SMSG) { SEV, LMSG }, +#endif +#include "bad.def" +#undef FFEBAD_MSGS1 +#undef FFEBAD_MSGS2 +}; + +static struct + { + ffewhereLine line; + ffewhereColumn col; + ffebadIndex tag; + } + +ffebad_here_[FFEBAD_MAX_]; +static char *ffebad_string_[FFEBAD_MAX_]; +static ffebadIndex ffebad_order_[FFEBAD_MAX_]; +static ffebad ffebad_errnum_; +static ffebadSeverity ffebad_severity_; +static char *ffebad_message_; +static unsigned char ffebad_index_; +static ffebadIndex ffebad_places_; +static bool ffebad_is_temp_inhibited_; /* Effective setting of + _is_inhibited_ for this + _start/_finish invocation. */ + +/* Static functions (internal). */ + +static int ffebad_bufputs_ (char buf[], int bufi, char *s); + +/* Internal macros. */ + +#define ffebad_bufflush_(buf, bufi) \ + (((buf)[bufi] = '\0'), fputs ((buf), stderr), 0) +#define ffebad_bufputc_(buf, bufi, c) \ + (((bufi) == ARRAY_SIZE (buf)) \ + ? (ffebad_bufflush_ ((buf), (bufi)), ((buf)[0] = (c)), 1) \ + : (((buf)[bufi] = (c)), (bufi) + 1)) + + +static int +ffebad_bufputs_ (char buf[], int bufi, char *s) +{ + for (; *s != '\0'; ++s) + bufi = ffebad_bufputc_ (buf, bufi, *s); + return bufi; +} + +/* ffebad_init_0 -- Initialize + + ffebad_init_0(); */ + +void +ffebad_init_0 () +{ + assert (FFEBAD == ARRAY_SIZE (ffebad_messages_)); +} + +ffebadSeverity +ffebad_severity (ffebad errnum) +{ + return ffebad_messages_[errnum].severity; +} + +/* ffebad_start_ -- Start displaying an error message + + ffebad_start(FFEBAD_SOME_ERROR_CODE); + + Call ffebad_start to establish the message, ffebad_here and ffebad_string + to send run-time data to it as necessary, then ffebad_finish when through + to actually get it to print (to stderr). + + Note: ffebad_start(errnum) turns into ffebad_start_(FALSE,errnum). No + outside caller should call ffebad_start_ directly (as indicated by the + trailing underscore). + + Call ffebad_start to start a normal message, one that might be inhibited + by the current state of statement guessing. Call ffebad_start_lex + instead to start a message that is global to all statement guesses and + happens only once for all guesses (i.e. the lexer). + + sev and message are overrides for the severity and messages when errnum + is FFEBAD, meaning the caller didn't want to have to put a message in + bad.def to produce a diagnostic. */ + +bool +ffebad_start_ (bool lex_override, ffebad errnum, ffebadSeverity sev, + char *message) +{ + unsigned char i; + + if (ffebad_is_inhibited_ && !lex_override) + { + ffebad_is_temp_inhibited_ = TRUE; + return FALSE; + } + + if (errnum != FFEBAD) + { + ffebad_severity_ = ffebad_messages_[errnum].severity; + ffebad_message_ = ffebad_messages_[errnum].message; + } + else + { + ffebad_severity_ = sev; + ffebad_message_ = message; + } + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + { + extern int inhibit_warnings; /* From toplev.c. */ + + 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 */ + + ffebad_is_temp_inhibited_ = FALSE; + ffebad_errnum_ = errnum; + ffebad_index_ = 0; + ffebad_places_ = 0; + for (i = 0; i < FFEBAD_MAX_; ++i) + { + ffebad_string_[i] = NULL; + ffebad_here_[i].line = ffewhere_line_unknown (); + ffebad_here_[i].col = ffewhere_column_unknown (); + } + + return TRUE; +} + +/* ffebad_here -- Establish source location of some diagnostic concern + + ffebad_here(ffebadIndex i,ffewhereLine line,ffewhereColumn col); + + Call ffebad_start to establish the message, ffebad_here and ffebad_string + to send run-time data to it as necessary, then ffebad_finish when through + to actually get it to print (to stderr). */ + +void +ffebad_here (ffebadIndex index, ffewhereLine line, ffewhereColumn col) +{ + ffewhereLineNumber line_num; + ffewhereLineNumber ln; + ffewhereColumnNumber col_num; + ffewhereColumnNumber cn; + ffebadIndex i; + ffebadIndex j; + + if (ffebad_is_temp_inhibited_) + return; + + assert (index < FFEBAD_MAX_); + ffebad_here_[index].line = ffewhere_line_use (line); + ffebad_here_[index].col = ffewhere_column_use (col); + if (ffewhere_line_is_unknown (line) + || ffewhere_column_is_unknown (col)) + { + ffebad_here_[index].tag = FFEBAD_MAX_; + return; + } + ffebad_here_[index].tag = 0; /* For now, though it shouldn't matter. */ + + /* Sort the source line/col points into the order they occur in the source + file. Deal with duplicates appropriately. */ + + line_num = ffewhere_line_number (line); + col_num = ffewhere_column_number (col); + + /* Determine where in the ffebad_order_ array this new place should go. */ + + for (i = 0; i < ffebad_places_; ++i) + { + ln = ffewhere_line_number (ffebad_here_[ffebad_order_[i]].line); + cn = ffewhere_column_number (ffebad_here_[ffebad_order_[i]].col); + if (line_num < ln) + break; + if (line_num == ln) + { + if (col_num == cn) + { + ffebad_here_[index].tag = i; + return; /* Shouldn't go in, has equivalent. */ + } + else if (col_num < cn) + break; + } + } + + /* Before putting new place in ffebad_order_[i], first increment all tags + that are i or greater. */ + + if (i != ffebad_places_) + { + for (j = 0; j < FFEBAD_MAX_; ++j) + { + if (ffebad_here_[j].tag >= i) + ++ffebad_here_[j].tag; + } + } + + /* Then slide all ffebad_order_[] entries at and above i up one entry. */ + + for (j = ffebad_places_; j > i; --j) + ffebad_order_[j] = ffebad_order_[j - 1]; + + /* Finally can put new info in ffebad_order_[i]. */ + + ffebad_order_[i] = index; + ffebad_here_[index].tag = i; + ++ffebad_places_; +} + +/* Establish string for next index (always in order) of message + + ffebad_string(char *string); + + Call ffebad_start to establish the message, ffebad_here and ffebad_string + to send run-time data to it as necessary, then ffebad_finish when through + to actually get it to print (to stderr). Note: don't trash the string + until after calling ffebad_finish, since we just maintain a pointer to + the argument passed in until then. */ + +void +ffebad_string (char *string) +{ + if (ffebad_is_temp_inhibited_) + return; + + assert (ffebad_index_ != FFEBAD_MAX_); + ffebad_string_[ffebad_index_++] = string; +} + +/* ffebad_finish -- Display error message with where & run-time info + + ffebad_finish(); + + Call ffebad_start to establish the message, ffebad_here and ffebad_string + to send run-time data to it as necessary, then ffebad_finish when through + to actually get it to print (to stderr). */ + +void +ffebad_finish () +{ +#define MAX_SPACES 132 + static char *spaces + = "...>\ +\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\ +\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\ +\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\ +\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\ +\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\ +\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\ +\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\ +\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\ +\040\040\040"; /* MAX_SPACES - 1 spaces. */ + ffewhereLineNumber last_line_num; + ffewhereLineNumber ln; + ffewhereLineNumber rn; + ffewhereColumnNumber last_col_num; + ffewhereColumnNumber cn; + ffewhereColumnNumber cnt; + ffewhereLine l; + ffebadIndex bi; + unsigned short i; + char pointer; + char c; + char *s; + char *fn; + static char buf[1024]; + int bufi; + int index; + + if (ffebad_is_temp_inhibited_) + return; + + switch (ffebad_severity_) + { + case FFEBAD_severityINFORMATIONAL: + s = "note:"; + break; + + case FFEBAD_severityWARNING: + s = "warning:"; + break; + + case FFEBAD_severitySEVERE: + s = "fatal:"; + break; + + default: + s = ""; + break; + } + + /* Display the annoying source references. */ + + last_line_num = 0; + last_col_num = 0; + + for (bi = 0; bi < ffebad_places_; ++bi) + { + if (ffebad_places_ == 1) + pointer = '^'; + else + pointer = '1' + bi; + + l = ffebad_here_[ffebad_order_[bi]].line; + ln = ffewhere_line_number (l); + rn = ffewhere_line_filelinenum (l); + cn = ffewhere_column_number (ffebad_here_[ffebad_order_[bi]].col); + fn = ffewhere_line_filename (l); + if (ln != last_line_num) + { + 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 :: 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], + pointer); + last_line_num = ln; + last_col_num = cn; + s = "(continued):"; + } + else + { + cnt = cn - last_col_num; + fprintf (stderr, + "%s%c", &spaces[cnt > MAX_SPACES + ? 0 : MAX_SPACES - cnt + 4], + pointer); + last_col_num = cn; + } + } + if (ffebad_places_ == 0) + { + /* Didn't output "warning:" string, capitalize it for message. */ + if ((s[0] != '\0') && isalpha (s[0]) && islower (s[0])) + { + char c; + + c = toupper (s[0]); + fprintf (stderr, "%c%s ", c, &s[1]); + } + else if (s[0] != '\0') + fprintf (stderr, "%s ", s); + } + else + fputc ('\n', stderr); + + /* Release the ffewhere info. */ + + for (bi = 0; bi < FFEBAD_MAX_; ++bi) + { + ffewhere_line_kill (ffebad_here_[bi].line); + ffewhere_column_kill (ffebad_here_[bi].col); + } + + /* Now display the message. */ + + bufi = 0; + for (i = 0; (c = ffebad_message_[i]) != '\0'; ++i) + { + if (c == '%') + { + c = ffebad_message_[++i]; + if (isalpha (c) && isupper (c)) + { + index = c - 'A'; + + if ((index < 0) || (index >= FFEBAD_MAX_)) + { + bufi = ffebad_bufputs_ (buf, bufi, "[REPORT BUG!!] %"); + bufi = ffebad_bufputc_ (buf, bufi, c); + } + else + { + s = ffebad_string_[index]; + if (s == NULL) + bufi = ffebad_bufputs_ (buf, bufi, "[REPORT BUG!!]"); + else + bufi = ffebad_bufputs_ (buf, bufi, s); + } + } + else if (isdigit (c)) + { + index = c - '0'; + + if ((index < 0) || (index >= FFEBAD_MAX_)) + { + bufi = ffebad_bufputs_ (buf, bufi, "[REPORT BUG!!] %"); + bufi = ffebad_bufputc_ (buf, bufi, c); + } + else + { + pointer = ffebad_here_[index].tag + '1'; + if (pointer == FFEBAD_MAX_ + '1') + pointer = '?'; + else if (ffebad_places_ == 1) + pointer = '^'; + bufi = ffebad_bufputc_ (buf, bufi, '('); + bufi = ffebad_bufputc_ (buf, bufi, pointer); + bufi = ffebad_bufputc_ (buf, bufi, ')'); + } + } + else if (c == '\0') + break; + else if (c == '%') + bufi = ffebad_bufputc_ (buf, bufi, '%'); + else + { + bufi = ffebad_bufputs_ (buf, bufi, "[REPORT BUG!!]"); + bufi = ffebad_bufputc_ (buf, bufi, '%'); + bufi = ffebad_bufputc_ (buf, bufi, c); + } + } + else + bufi = ffebad_bufputc_ (buf, bufi, c); + } + bufi = ffebad_bufputc_ (buf, bufi, '\n'); + bufi = ffebad_bufflush_ (buf, bufi); +} diff --git a/gcc/f/bad.def b/gcc/f/bad.def new file mode 100644 index 000000000000..507bfed55b01 --- /dev/null +++ b/gcc/f/bad.def @@ -0,0 +1,705 @@ +/* bad.def -- Public #include File (module.h template V1.0) + Copyright (C) 1995-1997 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + bad.c + + Modifications: +*/ + +#define INFORM FFEBAD_severityINFORMATIONAL +#define TRIVIAL FFEBAD_severityTRIVIAL +#define WARN FFEBAD_severityWARNING +#define PECULIAR FFEBAD_severityPECULIAR +#define FATAL FFEBAD_severityFATAL +#define WEIRD FFEBAD_severityWEIRD +#define SEVERE FFEBAD_severitySEVERE +#define DISASTER FFEBAD_severityDISASTER + +FFEBAD_MSGS1 (FFEBAD_MISSING_FIRST_BINARY_OPERAND, FATAL, +"Missing first operand for binary operator at %0") +FFEBAD_MSGS1 (FFEBAD_NULL_CHAR_CONST, WARN, +"Zero-length character constant at %0") +FFEBAD_MSGS1 (FFEBAD_INVALID_TOKEN_IN_EXPRESSION, FATAL, +"Invalid token at %0 in expression or subexpression at %1") +FFEBAD_MSGS1 (FFEBAD_MISSING_OPERAND_FOR_OPERATOR, FATAL, +"Missing operand for operator at %1 at end of expression at %0") +FFEBAD_MSGS1 (FFEBAD_LABEL_ALREADY_DEFINED, FATAL, +"Label %A already defined at %1 when redefined at %0") +FFEBAD_MSGS1 (FFEBAD_UNRECOGNIZED_CHARACTER, FATAL, +"Unrecognized character at %0 [info -f g77 M LEX]") +FFEBAD_MSGS1 (FFEBAD_LABEL_WITHOUT_STMT, WARN, +"Label definition %A at %0 on empty statement (as of %1)") +FFEBAD_MSGS2 (FFEBAD_EXTRA_LABEL_DEF, FATAL, +"Extra label definition %A at %0 -- perhaps previous label definition %B at %1 should have CONTINUE statement?", +"Extra label definition %A at %0 following label definition %B at %1") +FFEBAD_MSGS1 (FFEBAD_FIRST_CHAR_INVALID, FATAL, +"Invalid first character at %0 [info -f g77 M LEX]") +FFEBAD_MSGS1 (FFEBAD_LINE_TOO_LONG, FATAL, +"Line too long as of %0 [info -f g77 M LEX]") +FFEBAD_MSGS1 (FFEBAD_LABEL_FIELD_NOT_NUMERIC, FATAL, +"Non-numeric character at %0 in label field [info -f g77 M LEX]") +FFEBAD_MSGS1 (FFEBAD_LABEL_NUMBER_INVALID, FATAL, +"Label number at %0 not in range 1-99999") +FFEBAD_MSGS1 (FFEBAD_NON_ANSI_COMMENT, WARN, +"At %0, '!' and '/*' are not valid comment delimiters") +FFEBAD_MSGS1 (FFEBAD_NON_ANSI_CONTINUATION_COLUMN, WARN, +"Continuation indicator at %0 must appear in column 6 [info -f g77 M LEX]") +FFEBAD_MSGS1 (FFEBAD_LABEL_ON_CONTINUATION, FATAL, +"Label at %0 invalid with continuation line indicator at %1 [info -f g77 M LEX]") +FFEBAD_MSGS2 (FFEBAD_INVALID_CONTINUATION, FATAL, +"Continuation indicator at %0 invalid on first non-comment line of file or following END or INCLUDE [info -f g77 M LEX]", +"Continuation indicator at %0 invalid here [info -f g77 M LEX]") +FFEBAD_MSGS1 (FFEBAD_NO_CLOSING_APOSTROPHE, FATAL, +"Character constant at %0 has no closing apostrophe at %1") +FFEBAD_MSGS1 (FFEBAD_NOT_ENOUGH_HOLLERITH_CHARS, FATAL, +"Hollerith constant at %0 specified %A more characters than are present as of %1") +FFEBAD_MSGS1 (FFEBAD_MISSING_CLOSE_PAREN, FATAL, +"Missing close parenthese at %0 needed to match open parenthese at %1") +FFEBAD_MSGS1 (FFEBAD_INTEGER_TOO_LARGE, FATAL, +"Integer at %0 too large") +FFEBAD_MSGS2 (FFEBAD_BAD_MAGICAL, WARN, +"Integer at %0 too large except as negative number (preceded by unary minus sign)", +"Non-negative integer at %0 too large") +FFEBAD_MSGS2 (FFEBAD_BAD_MAGICAL_PRECEDENCE, WARN, +"Integer at %0 too large; even though preceded by unary minus sign at %1, subsequent operator at %2 has precedence over unary minus -- enclose unary minus sign and integer in parentheses to force precedence", +"Integer at %0 too large (%2 has precedence over %1)") +FFEBAD_MSGS2 (FFEBAD_BAD_MAGICAL_BINARY, WARN, +"Integer at %0 too large; even though preceded by minus sign at %1, because minus sign is a binary, not unary, operator -- insert plus sign before minus sign to change it to a unary minus sign", +"Integer at %0 too large (needs unary, not binary, minus at %1)") +FFEBAD_MSGS2 (FFEBAD_BAD_MAGICAL_PRECEDENCE_BINARY, WARN, +"Integer at %0 too large; even though preceded by minus sign at %1, subsequent operator at %2 has precedence over minus, and that minus sign should be a unary minus rather than a binary minus -- insert plus sign before minus sign to change it to a unary minus sign, and enclose unary minus sign and integer in parentheses to force precedence", +"Integer at %0 too large (%2 has precedence over %1, which needs to be unary, not binary, minus)") +FFEBAD_MSGS1 (FFEBAD_IGNORING_PERIOD, FATAL, +"Period at %0 not followed by digits for floating-point number or by `NOT.', `TRUE.', or `FALSE.'") +FFEBAD_MSGS1 (FFEBAD_INSERTING_PERIOD, FATAL, +"Missing close-period between `.%A' at %0 and %1") +FFEBAD_MSGS1 (FFEBAD_INVALID_EXPONENT, FATAL, +"Invalid exponent at %0 for real constant at %1; nondigit `%A' in exponent field") +FFEBAD_MSGS1 (FFEBAD_MISSING_EXPONENT_VALUE, FATAL, +"Missing value at %1 for real-number exponent at %0") +FFEBAD_MSGS1 (FFEBAD_MISSING_BINARY_OPERATOR, FATAL, +"Expected binary operator between expressions at %0 and at %1") +FFEBAD_MSGS2 (FFEBAD_INVALID_DOTDOT, FATAL, +"Period at %0 not followed by valid keyword forming a valid binary operator; `.%A.' is not a valid binary operator", +"`.%A.' at %0 not a binary operator") +FFEBAD_MSGS2 (FFEBAD_QUOTE_MISSES_DIGITS, FATAL, +"Double-quote at %0 not followed by a string of valid octal digits at %1", +"Invalid octal constant at %0") +FFEBAD_MSGS2 (FFEBAD_INVALID_BINARY_DIGIT, FATAL, +"Invalid binary digit(s) found in string of digits at %0", +"Invalid binary constant at %0") +FFEBAD_MSGS2 (FFEBAD_INVALID_HEX_DIGIT, FATAL, +"Invalid hexadecimal digit(s) found in string of digits at %0", +"Invalid hexadecimal constant at %0") +FFEBAD_MSGS2 (FFEBAD_INVALID_OCTAL_DIGIT, FATAL, +"Invalid octal digit(s) found in string of digits at %0", +"Invalid octal constant at %0") +FFEBAD_MSGS2 (FFEBAD_INVALID_RADIX_SPECIFIER, FATAL, +"Invalid radix specifier `%A' at %0 for typeless constant at %1", +"Invalid typeless constant at %1") +FFEBAD_MSGS2 (FFEBAD_INVALID_TYPELESS_BINARY_DIGIT, FATAL, +"Invalid binary digit(s) found in string of digits at %0", +"Invalid binary constant at %0") +FFEBAD_MSGS2 (FFEBAD_INVALID_TYPELESS_OCTAL_DIGIT, FATAL, +"Invalid octal digit(s) found in string of digits at %0", +"Invalid octal constant at %0") +FFEBAD_MSGS2 (FFEBAD_INVALID_TYPELESS_HEX_DIGIT, FATAL, +"Invalid hexadecimal digit(s) found in string of digits at %0", +"Invalid hexadecimal constant at %0") +FFEBAD_MSGS2 (FFEBAD_INVALID_COMPLEX_PART, FATAL, +"%A part of complex constant at %0 must be a real or integer constant -- otherwise use CMPLX() or COMPLEX() in place of ()", +"%A part of complex constant at %0 not a real or integer constant") +FFEBAD_MSGS2 (FFEBAD_INVALID_PERCENT, FATAL, +"Invalid keyword `%%%A' at %0 in this context", +"Invalid keyword `%%%A' at %0") +FFEBAD_MSGS2 (FFEBAD_NULL_EXPRESSION, FATAL, +"Null expression between %0 and %1 invalid in this context", +"Invalid null expression between %0 and %1") +FFEBAD_MSGS2 (FFEBAD_CONCAT_ARGS_TYPE, FATAL, +"Concatenation operator at %0 must operate on two subexpressions of character type, but neither subexpression at %1 or %2 is of character type", +"Invalid operands at %1 and %2 for concatenation operator at %0") +FFEBAD_MSGS2 (FFEBAD_CONCAT_ARG_TYPE, FATAL, +"Concatenation operator at %0 must operate on two subexpressions of character type, but the subexpression at %1 is not of character type", +"Invalid operand at %1 for concatenation operator at %0") +FFEBAD_MSGS2 (FFEBAD_CONCAT_ARG_KIND, FATAL, +"Concatenation operator at %0 must operate on two scalar (not array) subexpressions, two function invocations returning character scalars, or a combination of both -- but the subexpression at %1 is %A", +"Invalid operand (is %A) at %1 for concatenation operator at %0") +FFEBAD_MSGS2 (FFEBAD_MATH_ARGS_TYPE, FATAL, +"Arithmetic operator at %0 must operate on two subexpressions of arithmetic type, but neither subexpression at %1 or %2 is of arithmetic type", +"Invalid operands at %1 and %2 for arithmetic operator at %0") +FFEBAD_MSGS2 (FFEBAD_MATH_ARG_TYPE, FATAL, +"Arithmetic operator at %0 must operate on two subexpressions of arithmetic type, but the subexpression at %1 is not of arithmetic type", +"Invalid operand at %1 for arithmetic operator at %0") +FFEBAD_MSGS2 (FFEBAD_MATH_ARG_KIND, FATAL, +"Arithmetic operator at %0 must operate on two scalar (not array) subexpressions, two function invocations returning arithmetic scalars, or a combination of both -- but the subexpression at %1 is %A", +"Invalid operand (is %A) at %1 for arithmetic operator at %0") +FFEBAD_MSGS2 (FFEBAD_NO_CLOSING_QUOTE, FATAL, +"Character constant at %0 has no closing quote at %1 [info -f g77 M LEX]", +"Unterminated character constant at %0 [info -f g77 M LEX]") +FFEBAD_MSGS2 (FFEBAD_BAD_CHAR_CONTINUE, FATAL, +"Continuation line at %0 must have initial `&' since it continues a character context [info -f g77 M LEX]", +"Missing initial `&' on continuation line at %0 [info -f g77 M LEX]") +FFEBAD_MSGS2 (FFEBAD_BAD_LEXTOK_CONTINUE, FATAL, +"Continuation line at %0 must have initial `&' since it continues a split lexical token [info -f g77 M LEX]", +"Missing initial `&' on continuation line at %0 [info -f g77 M LEX]") +FFEBAD_MSGS2 (FFEBAD_BAD_FREE_CONTINUE, FATAL, +"Continuation line at %0 invalid because it consists only of a single `&' as the only nonblank character", +"Invalid continuation line at %0") +FFEBAD_MSGS2 (FFEBAD_STMT_BEGINS_BAD, FATAL, +"Statement at %0 begins with invalid token [info -f g77 M LEX]", +"Invalid statement at %0 [info -f g77 M LEX]") +FFEBAD_MSGS1 (FFEBAD_SEMICOLON, FATAL, +"Semicolon at %0 is an invalid token") +FFEBAD_MSGS2 (FFEBAD_UNREC_STMT, FATAL, +"Unrecognized statement name at %0 and invalid form for assignment or statement-function definition at %1", +"Invalid statement at %0") +FFEBAD_MSGS2 (FFEBAD_INVALID_STMT_FORM, FATAL, +"Invalid form for %A statement at %0", +"Invalid %A statement at %0") +FFEBAD_MSGS2 (FFEBAD_INVALID_HOLL_IN_STMT, FATAL, +"Invalid use of hollerith constant in statement at %0 -- enclose the constant in parentheses (for example, change BACKSPACE 2HAB to BACKSPACE (2HAB))", +"Enclose hollerith constant in statement at %0 in parentheses") +FFEBAD_MSGS1 (FFEBAD_FORMAT_EXTRA_COMMA, FATAL, +"Extraneous comma in FORMAT statement at %0") +FFEBAD_MSGS1 (FFEBAD_FORMAT_MISSING_COMMA, WARN, +"Missing comma in FORMAT statement at %0") +FFEBAD_MSGS1 (FFEBAD_FORMAT_SPURIOUS_SIGN, FATAL, +"Spurious sign in FORMAT statement at %0") +FFEBAD_MSGS1 (FFEBAD_FORMAT_SPURIOUS_NUMBER, FATAL, +"Spurious number in FORMAT statement at %0") +FFEBAD_MSGS1 (FFEBAD_FORMAT_TEXT_IN_NUMBER, FATAL, +"Spurious text trailing number in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_P_NOCOMMA, FATAL, +"nP control edit descriptor not followed by comma but followed by edit descriptor at %0 other than D, E, EN, F, or G", +"Invalid edit descriptor at %0 following nP control edit descriptor") +FFEBAD_MSGS1 (FFEBAD_FORMAT_BAD_SPEC, FATAL, +"Unrecognized FORMAT specifier at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_I_SPEC, FATAL, +"Invalid I specifier in FORMAT statement at %0 -- correct form: [r]Iw.[m]", +"Invalid I specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_B_SPEC, FATAL, +"Invalid B specifier in FORMAT statement at %0 -- correct form: [r]Bw.[m]", +"Invalid B specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_O_SPEC, FATAL, +"Invalid O specifier in FORMAT statement at %0 -- correct form: [r]Ow.[m]", +"Invalid O specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_Z_SPEC, FATAL, +"Invalid Z specifier in FORMAT statement at %0 -- correct form: [r]Zw.[m]", +"Invalid Z specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_F_SPEC, FATAL, +"Invalid F specifier in FORMAT statement at %0 -- correct form: [r]Fw.d", +"Invalid F specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_E_SPEC, FATAL, +"Invalid E specifier in FORMAT statement at %0 -- correct form: [r]Ew.d[Ee]", +"Invalid E specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_EN_SPEC, FATAL, +"Invalid EN specifier in FORMAT statement at %0 -- correct form: [r]ENw.d[Ee]", +"Invalid EN specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_G_SPEC, FATAL, +"Invalid G specifier in FORMAT statement at %0 -- correct form: [r]Gw.d[Ee]", +"Invalid G specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_L_SPEC, FATAL, +"Invalid L specifier in FORMAT statement at %0 -- correct form: [r]Lw", +"Invalid L specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_A_SPEC, FATAL, +"Invalid A specifier in FORMAT statement at %0 -- correct form: [r]A[w]", +"Invalid A specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_D_SPEC, FATAL, +"Invalid D specifier in FORMAT statement at %0 -- correct form: [r]Dw.d", +"Invalid D specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_Q_SPEC, FATAL, +"Invalid Q specifier in FORMAT statement at %0 -- correct form: Q", +"Invalid Q specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_DOLLAR_SPEC, FATAL, +"Invalid $ specifier in FORMAT statement at %0 -- correct form: $", +"Invalid $ specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_P_SPEC, FATAL, +"Invalid P specifier in FORMAT statement at %0 -- correct form: kP", +"Invalid P specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_T_SPEC, FATAL, +"Invalid T specifier in FORMAT statement at %0 -- correct form: Tn", +"Invalid T specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_TL_SPEC, FATAL, +"Invalid TL specifier in FORMAT statement at %0 -- correct form: TLn", +"Invalid TL specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_TR_SPEC, FATAL, +"Invalid TR specifier in FORMAT statement at %0 -- correct form: TRn", +"Invalid TR specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_X_SPEC, FATAL, +"Invalid X specifier in FORMAT statement at %0 -- correct form: nX", +"Invalid X specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_S_SPEC, FATAL, +"Invalid S specifier in FORMAT statement at %0 -- correct form: S", +"Invalid S specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_SP_SPEC, FATAL, +"Invalid SP specifier in FORMAT statement at %0 -- correct form: SP", +"Invalid SP specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_SS_SPEC, FATAL, +"Invalid SS specifier in FORMAT statement at %0 -- correct form: SS", +"Invalid SS specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_BN_SPEC, FATAL, +"Invalid BN specifier in FORMAT statement at %0 -- correct form: BN", +"Invalid BN specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_BZ_SPEC, FATAL, +"Invalid BZ specifier in FORMAT statement at %0 -- correct form: BZ", +"Invalid BZ specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_COLON_SPEC, FATAL, +"Invalid : specifier in FORMAT statement at %0 -- correct form: :", +"Invalid : specifier in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_BAD_H_SPEC, FATAL, +"Invalid H specifier in FORMAT statement at %0 -- correct form: nHcharacters !where n is an unsigned decimal constant, and characters !contains exactly n characters (including spaces)", +"Invalid H specifier in FORMAT statement at %0") +FFEBAD_MSGS1 (FFEBAD_FORMAT_MISSING_PAREN, FATAL, +"Missing close-parenthese(s) in FORMAT statement at %0") +FFEBAD_MSGS1 (FFEBAD_FORMAT_MISSING_DOT, FATAL, +"Missing number following period in FORMAT statement at %0") +FFEBAD_MSGS1 (FFEBAD_FORMAT_MISSING_EXP, FATAL, +"Missing number following `E' in FORMAT statement at %0") +FFEBAD_MSGS2 (FFEBAD_FORMAT_EXPR_TOKEN, FATAL, +"Invalid token with FORMAT run-time expression at %0 -- use the traditional operators .LT., .LE., .GT., .GE., .EQ., and .NE. in place of the newer tokens <, <=, >, >=, ==, and !=, because > ends an expression within a FORMAT statement", +"Invalid token with FORMAT run-time expression at %0") +FFEBAD_MSGS1 (FFEBAD_TRAILING_COMMA, WARN, +"Spurious trailing comma preceding terminator at %0") +FFEBAD_MSGS1 (FFEBAD_INTERFACE_ASSIGNMENT, WARN, +"At %0, specify OPERATOR instead of ASSIGNMENT for INTERFACE statement not specifying the assignment operator (=)") +FFEBAD_MSGS1 (FFEBAD_INTERFACE_OPERATOR, WARN, +"At %0, specify ASSIGNMENT instead of OPERATOR for INTERFACE statement specifying the assignment operator (=)") +FFEBAD_MSGS2 (FFEBAD_INTERFACE_NONLETTER, FATAL, +"Defined operator at %0 contains a nonletter -- must contain only letters A-Z (or a-z)", +"Nonletter in defined operator at %0") +FFEBAD_MSGS2 (FFEBAD_INVALID_TYPEDECL_ATTR, FATAL, +"Invalid type-declaration attribute at %0 -- must be one of: DIMENSION(array-spec), EXTERNAL, INTRINSIC, PARAMETER, or SAVE", +"Invalid type-declaration attribute at %0") +FFEBAD_MSGS1 (FFEBAD_INVALID_TYPEDECL_INIT, FATAL, +"Cannot specify =initialization-expr at %0 unless `::' appears before list of objects") +FFEBAD_MSGS1 (FFEBAD_LABEL_USE_DEF, FATAL, +"Reference to label at %1 inconsistent with its definition at %0") +FFEBAD_MSGS1 (FFEBAD_LABEL_USE_USE, FATAL, +"Reference to label at %1 inconsistent with earlier reference at %0") +FFEBAD_MSGS1 (FFEBAD_LABEL_DEF_DO, FATAL, +"DO-statement reference to label at %1 follows its definition at %0") +FFEBAD_MSGS1 (FFEBAD_LABEL_BLOCK, WARN, +"Reference to label at %1 is outside block containing definition at %0") +FFEBAD_MSGS1 (FFEBAD_LABEL_DO_BLOCK_DO, FATAL, +"DO-statement references to label at %0 and %2 separated by unterminated block starting at %1") +FFEBAD_MSGS1 (FFEBAD_LABEL_DO_BLOCK_END, FATAL, +"DO-statement reference to label at %0 and label definition at %2 separated by unterminated block starting at %1") +FFEBAD_MSGS1 (FFEBAD_INVALID_LABEL_DEF, FATAL, +"Label definition at %0 invalid on this kind of statement") +FFEBAD_MSGS1 (FFEBAD_ORDER_1, FATAL, +"Statement at %0 invalid in this context") +FFEBAD_MSGS1 (FFEBAD_ORDER_2, FATAL, +"Statement at %0 invalid in context established by statement at %1") +FFEBAD_MSGS1 (FFEBAD_CONSTRUCT_NAMED, FATAL, +"Statement at %0 must specify construct name specified at %1") +FFEBAD_MSGS1 (FFEBAD_CONSTRUCT_NOT_NAMED, FATAL, +"Construct name at %0 superfluous, no construct name specified at %1") +FFEBAD_MSGS1 (FFEBAD_CONSTRUCT_WRONG_NAME, FATAL, +"Construct name at %0 not the same as construct name at %1") +FFEBAD_MSGS1 (FFEBAD_CONSTRUCT_NO_DO_NAME, FATAL, +"Construct name at %0 does not match construct name for any containing DO constructs") +FFEBAD_MSGS1 (FFEBAD_DO_HAD_LABEL, FATAL, +"Label definition missing at %0 for DO construct specifying label at %1") +FFEBAD_MSGS1 (FFEBAD_AFTER_ELSE, FATAL, +"Statement at %0 follows ELSE block for IF construct at %1") +FFEBAD_MSGS1 (FFEBAD_FORMAT_NO_LABEL_DEF, FATAL, +"No label definition for FORMAT statement at %0") +FFEBAD_MSGS1 (FFEBAD_SECOND_ELSE_WHERE, FATAL, +"Second occurrence of ELSE WHERE at %0 within WHERE at %1") +FFEBAD_MSGS1 (FFEBAD_END_WO, WARN, +"END statement at %0 missing `%A' keyword required for internal or module procedure(s) bounded by %1") +FFEBAD_MSGS1 (FFEBAD_INVALID_MODULE_PROCEDURE, FATAL, +"MODULE PROCEDURE statement at %0 disallowed because INTERFACE at %1 specifies no generic name, operator, or assignment") +FFEBAD_MSGS1 (FFEBAD_BLOCKDATA_NOT_NAMED, FATAL, +"BLOCK DATA name at %0 superfluous, no name specified at %1") +FFEBAD_MSGS1 (FFEBAD_PROGRAM_NOT_NAMED, FATAL, +"Program name at %0 superfluous, no PROGRAM statement specified at %1") +FFEBAD_MSGS1 (FFEBAD_UNIT_WRONG_NAME, FATAL, +"Program unit name at %0 not the same as name at %1") +FFEBAD_MSGS1 (FFEBAD_TYPE_WRONG_NAME, FATAL, +"Type name at %0 not the same as name at %1") +FFEBAD_MSGS1 (FFEBAD_EOF_BEFORE_BLOCK_END, FATAL, +"End of source file before end of block started at %0") +FFEBAD_MSGS1 (FFEBAD_UNDEF_LABEL, FATAL, +"Undefined label, first referenced at %0") +FFEBAD_MSGS1 (FFEBAD_CONFLICTING_SAVES, WARN, +"SAVE statement or attribute at %1 cannot be specified along with SAVE statement or attribute at %0") +FFEBAD_MSGS1 (FFEBAD_CONFLICTING_ACCESSES, FATAL, +"PUBLIC or PRIVATE statement at %1 cannot be specified along with PUBLIC or PRIVATE statement at %0") +FFEBAD_MSGS1 (FFEBAD_RETURN_IN_MAIN, WARN, +"RETURN statement at %0 invalid within a main program unit") +FFEBAD_MSGS1 (FFEBAD_ALTRETURN_IN_PROGRAM, FATAL, +"Alternate return specifier at %0 invalid within a main program unit") +FFEBAD_MSGS1 (FFEBAD_ALTRETURN_IN_FUNCTION, FATAL, +"Alternate return specifier at %0 invalid within a function") +FFEBAD_MSGS1 (FFEBAD_DERIVTYP_ACCESS, FATAL, +"Access specifier or PRIVATE statement at %0 invalid for derived-type definition within other than the specification part of a module") +FFEBAD_MSGS1 (FFEBAD_DERIVTYP_ACCESS_FIRST, FATAL, +"Access specifier at %0 must immediately follow derived-type statement at %1 with no intervening statements") +FFEBAD_MSGS1 (FFEBAD_DERIVTYP_NO_COMPONENTS, FATAL, +"No components specified as of %0 for derived-type definition beginning at %1") +FFEBAD_MSGS1 (FFEBAD_STRUCT_NO_COMPONENTS, FATAL, +"No components specified as of %0 for structure definition beginning at %1") +FFEBAD_MSGS1 (FFEBAD_STRUCT_MISSING_NAME, FATAL, +"Missing structure name for outer structure definition at %0") +FFEBAD_MSGS1 (FFEBAD_STRUCT_IGNORING_FIELD, FATAL, +"Field names at %0 for outer structure definition -- specify them in a subsequent RECORD statement instead") +FFEBAD_MSGS1 (FFEBAD_STRUCT_MISSING_FIELD, FATAL, +"Missing field name(s) for structure definition at %0 within structure definition at %1") +FFEBAD_MSGS1 (FFEBAD_MAP_NO_COMPONENTS, FATAL, +"No components specified as of %0 for map beginning at %1") +FFEBAD_MSGS1 (FFEBAD_UNION_NO_TWO_MAPS, FATAL, +"Zero or one maps specified as of %0 for union beginning at %1 -- at least two are required") +FFEBAD_MSGS1 (FFEBAD_MISSING_SPECIFIER, FATAL, +"Missing %A specifier in statement at %0") +FFEBAD_MSGS1 (FFEBAD_NAMELIST_ITEMS, FATAL, +"Items in I/O list starting at %0 invalid for namelist-directed I/O") +FFEBAD_MSGS1 (FFEBAD_CONFLICTING_SPECS, FATAL, +"Conflicting I/O control specifications at %0 and %1") +FFEBAD_MSGS1 (FFEBAD_NO_UNIT_SPEC, FATAL, +"No UNIT= specifier in I/O control list at %0") +FFEBAD_MSGS1 (FFEBAD_MISSING_ADVANCE_SPEC, FATAL, +"Specification at %0 requires ADVANCE=`NO' specification in same I/O control list") +FFEBAD_MSGS1 (FFEBAD_MISSING_FORMAT_SPEC, FATAL, +"Specification at %0 requires explicit FMT= specification in same I/O control list") +FFEBAD_MSGS2 (FFEBAD_SPEC_VALUE, FATAL, +"Unrecognized value for character constant at %0 -- expecting %A", +"Unrecognized value for character constant at %0") +FFEBAD_MSGS1 (FFEBAD_CASE_SECOND_DEFAULT, FATAL, +"Second occurrence of CASE DEFAULT at %0 within SELECT CASE at %1") +FFEBAD_MSGS1 (FFEBAD_CASE_DUPLICATE, FATAL, +"Duplicate or overlapping case values/ranges at %0 and %1") +FFEBAD_MSGS1 (FFEBAD_CASE_TYPE_DISAGREE, FATAL, +"Type and/or kind-type parameter disagreement between CASE value or value within range at %0 and SELECT CASE at %1") +FFEBAD_MSGS1 (FFEBAD_CASE_LOGICAL_RANGE, FATAL, +"Range specification at %0 invalid for CASE statement within logical-type SELECT CASE statement") +FFEBAD_MSGS2 (FFEBAD_CASE_BAD_RANGE, FATAL, +"Range specification at %0 invalid -- at least one expression must be specified, or use CASE DEFAULT", +"Range specification at %0 invalid") +FFEBAD_MSGS2 (FFEBAD_CASE_RANGE_USELESS, INFORM, +"Range specification at %0 useless; first expression greater than second expression in range, so range can never be matched by any selection expression", +"Useless range at %0") +FFEBAD_MSGS1 (FFEBAD_F90, FATAL, +"Fortran 90 feature at %0 unsupported") +FFEBAD_MSGS2 (FFEBAD_KINDTYPE, FATAL, +"Invalid kind at %0 for type at %1 -- unsupported or not permitted", +"Invalid kind at %0 for type at %1") +FFEBAD_MSGS2 (FFEBAD_BAD_IMPLICIT, FATAL, +"Cannot establish implicit type for initial letter `%A' at %0 -- already explicitly established or used to set implicit type of some name, or backwards order of letters in letter range", +"Cannot establish implicit type for initial letter `%A' at %0") +FFEBAD_MSGS1 (FFEBAD_SYMERR, FATAL, +"Invalid declaration of or reference to symbol `%A' at %0 [initially seen at %1]") +FFEBAD_MSGS2 (FFEBAD_LABEL_WRONG_PLACE, FATAL, +"Label definition %A (at %0) invalid -- must be in columns 1-5", +"Invalid label definition %A (at %0)") +FFEBAD_MSGS1 (FFEBAD_NULL_ELEMENT, FATAL, +"Null element at %0 for array reference at %1") +FFEBAD_MSGS1 (FFEBAD_TOO_FEW_ELEMENTS, FATAL, +"Too few elements (%A missing) as of %0 for array reference at %1") +FFEBAD_MSGS1 (FFEBAD_TOO_MANY_ELEMENTS, FATAL, +"Too many elements as of %0 for array reference at %1") +FFEBAD_MSGS1 (FFEBAD_MISSING_COLON_IN_SUBSTR, FATAL, +"Missing colon as of %0 in substring reference for %1") +FFEBAD_MSGS1 (FFEBAD_BAD_SUBSTR, FATAL, +"Invalid use at %0 of substring operator on %1") +FFEBAD_MSGS1 (FFEBAD_RANGE_SUBSTR, WARN, +"Substring begin/end point at %0 out of defined range") +FFEBAD_MSGS1 (FFEBAD_RANGE_ARRAY, WARN, +"Array element value at %0 out of defined range") +FFEBAD_MSGS1 (FFEBAD_EXPR_WRONG, FATAL, +"Expression at %0 has incorrect data type or rank for its context") +FFEBAD_MSGS1 (FFEBAD_DIV_BY_ZERO, WARN, +"Division by 0 (zero) at %0 (IEEE not yet supported)") +FFEBAD_MSGS1 (FFEBAD_DO_STEP_ZERO, FATAL, +"%A step count known to be 0 (zero) at %0") +FFEBAD_MSGS1 (FFEBAD_DO_END_OVERFLOW, WARN, +"%A end value plus step count known to overflow at %0") +FFEBAD_MSGS1 (FFEBAD_DO_IMP_OVERFLOW, WARN, +"%A begin, end, and step-count values known to result in implementation-dependent behavior due to overflow(s) in intermediate calculations at %0") +FFEBAD_MSGS1 (FFEBAD_DO_NULL, WARN, +"%A begin, end, and step-count values known to result in no iterations at %0") +FFEBAD_MSGS1 (FFEBAD_BAD_TYPES, FATAL, +"Type disagreement between expressions at %0 and %1") +FFEBAD_MSGS2 (FFEBAD_FORMAT_EXPR_SPEC, FATAL, +"Run-time expression at %0 in FORMAT statement that does not follow the first executable statement in the program unit -- move the statement", +"FORMAT at %0 with run-time expression must follow first executable statement") +FFEBAD_MSGS2 (FFEBAD_BAD_IMPDO, FATAL, +"Unexpected token at %0 in implied-DO construct at %1 -- form of implied-DO is `(item-list,do-var=start,end[,incr])'", +"Unexpected token at %0 in implied-DO construct at %1") +FFEBAD_MSGS1 (FFEBAD_BAD_IMPDCL, FATAL, +"No specification for implied-DO iterator `%A' at %0") +FFEBAD_MSGS1 (FFEBAD_IMPDO_PAREN, WARN, +"Gratuitous parentheses surround implied-DO construct at %0") +FFEBAD_MSGS1 (FFEBAD_ZERO_SIZE, FATAL, +"Zero-size specification invalid at %0") +FFEBAD_MSGS1 (FFEBAD_ZERO_ARRAY, FATAL, +"Zero-size array at %0") +FFEBAD_MSGS1 (FFEBAD_BAD_COMPLEX, FATAL, +"Target machine does not support complex entity of kind specified at %0") +FFEBAD_MSGS1 (FFEBAD_BAD_DBLCMPLX, FATAL, +"Target machine does not support DOUBLE COMPLEX, specified at %0") +FFEBAD_MSGS1 (FFEBAD_BAD_POWER, WARN, +"Attempt to raise constant zero to a power at %0") +FFEBAD_MSGS2 (FFEBAD_BOOL_ARGS_TYPE, FATAL, +"Boolean/logical operator at %0 must operate on two subexpressions of logical type, but neither subexpression at %1 or %2 is of logical type", +"Invalid operands at %1 and %2 for boolean operator at %0") +FFEBAD_MSGS2 (FFEBAD_BOOL_ARG_TYPE, FATAL, +"Boolean/logical operator at %0 must operate on two subexpressions of logical type, but the subexpression at %1 is not of logical type", +"Invalid operand at %1 for boolean operator at %0") +FFEBAD_MSGS2 (FFEBAD_BOOL_ARG_KIND, FATAL, +"Boolean/logical operator at %0 must operate on two scalar (not array) subexpressions, two function invocations returning logical scalars, or a combination of both -- but the subexpression at %1 is %A", +"Invalid operand (is %A) at %1 for boolean operator at %0") +FFEBAD_MSGS2 (FFEBAD_NOT_ARG_TYPE, FATAL, +".NOT. operator at %0 must operate on subexpression of logical type, but the subexpression at %1 is not of logical type", +"Invalid operand at %1 for .NOT. operator at %0") +FFEBAD_MSGS2 (FFEBAD_NOT_ARG_KIND, FATAL, +".NOT. operator at %0 must operate on scalar subexpressions -- but the subexpression at %1 is %A", +"Invalid operand (is %A) at %1 for .NOT. operator at %0") +FFEBAD_MSGS2 (FFEBAD_EQOP_ARGS_TYPE, FATAL, +"Equality operator at %0 must operate on two subexpressions of arithmetic or character type, but neither subexpression at %1 or %2 is of arithmetic or character type", +"Invalid operands at %1 and %2 for equality operator at %0") +FFEBAD_MSGS2 (FFEBAD_EQOP_ARG_TYPE, FATAL, +"Equality operator at %0 must operate on two subexpressions of arithmetic or character type, but the subexpression at %1 is not of arithmetic or character type", +"Invalid operand at %1 for equality operator at %0") +FFEBAD_MSGS2 (FFEBAD_EQOP_ARG_KIND, FATAL, +"Equality operator at %0 must operate on two scalar (not array) subexpressions, two function invocations returning arithmetic or character scalars, or a combination of both -- but the subexpression at %1 is %A", +"Invalid operand (is %A) at %1 for equality operator at %0") +FFEBAD_MSGS2 (FFEBAD_RELOP_ARGS_TYPE, FATAL, +"Relational operator at %0 must operate on two subexpressions of integer, real, or character type, but neither subexpression at %1 or %2 is of integer, real, or character type", +"Invalid operands at %1 and %2 for relational operator at %0") +FFEBAD_MSGS2 (FFEBAD_RELOP_ARG_TYPE, FATAL, +"Relational operator at %0 must operate on two subexpressions of integer, real, or character type, but the subexpression at %1 is not of integer, real, or character type", +"Invalid operand at %1 for relational operator at %0") +FFEBAD_MSGS2 (FFEBAD_RELOP_ARG_KIND, FATAL, +"Relational operator at %0 must operate on two scalar (not array) subexpressions, two function invocations returning integer, real, or character scalars, or a combination of both -- but the subexpression at %1 is %A", +"Invalid operand (is %A) at %1 for relational operator at %0") +FFEBAD_MSGS2 (FFEBAD_INTRINSIC_REF, FATAL, +"Reference to intrinsic `%A' at %0 invalid -- one or more arguments have incorrect type", +"Invalid reference to intrinsic `%A' at %0") +FFEBAD_MSGS2 (FFEBAD_INTRINSIC_TOOFEW, FATAL, +"Too few arguments passed to intrinsic `%A' at %0", +"Too few arguments for intrinsic `%A' at %0") +FFEBAD_MSGS2 (FFEBAD_INTRINSIC_TOOMANY, FATAL, +"Too many arguments passed to intrinsic `%A' at %0", +"Too many arguments for intrinsic `%A' at %0") +FFEBAD_MSGS2 (FFEBAD_INTRINSIC_DISABLED, FATAL, +"Reference to disabled intrinsic `%A' at %0", +"Disabled intrinsic `%A' at %0") +FFEBAD_MSGS2 (FFEBAD_INTRINSIC_IS_SUBR, FATAL, +"Reference to intrinsic subroutine `%A' as if it were a function at %0", +"Function reference to intrinsic subroutine `%A' at %0") +FFEBAD_MSGS2 (FFEBAD_INTRINSIC_IS_FUNC, FATAL, +"Reference to intrinsic function `%A' as if it were a subroutine at %0", +"Subroutine reference to intrinsic function `%A' at %0") +FFEBAD_MSGS2 (FFEBAD_INTRINSIC_UNIMPL, FATAL, +"Reference to unimplemented intrinsic `%A' at %0 -- use EXTERNAL to reference user-written procedure with this name", +"Unimplemented intrinsic `%A' at %0") +FFEBAD_MSGS2 (FFEBAD_INTRINSIC_UNIMPLW, WARN, +"Reference to unimplemented intrinsic `%A' at %0 (assumed EXTERNAL)", +"Unimplemented intrinsic `%A' at %0 (assumed EXTERNAL)") +FFEBAD_MSGS1 (FFEBAD_INTRINSIC_AMBIG, FATAL, +"Reference to generic intrinsic `%A' at %0 could be to form %B or %C") +FFEBAD_MSGS1 (FFEBAD_INTRINSIC_CMPAMBIG, FATAL, +"Ambiguous use of intrinsic `%A' at %0 [info -f g77 M CMPAMBIG]") +FFEBAD_MSGS1 (FFEBAD_INTRINSIC_EXPIMP, WARN, +"Intrinsic `%A' referenced %Bly at %0, %Cly at %1 [info -f g77 M EXPIMP]") +FFEBAD_MSGS1 (FFEBAD_INTRINSIC_GLOBAL, WARN, +"Same name `%A' used for %B at %0 and %C at %1 [info -f g77 M INTGLOB]") +FFEBAD_MSGS1 (FFEBAD_INTRINSIC_TYPE, WARN, +"Explicit type declaration for intrinsic `%A' disagrees with invocation at %0") +FFEBAD_MSGS1 (FFEBAD_OPEN_INCLUDE, FATAL, +"Unable to open INCLUDE file `%A' at %0") +FFEBAD_MSGS2 (FFEBAD_DOITER, FATAL, +"Attempt to modify variable `%A' at %0 while it serves as DO-loop iterator at %1", +"Modification of DO-loop iterator `%A' at %0") +FFEBAD_MSGS2 (FFEBAD_DOITER_IMPDO, FATAL, +"Attempt to modify variable `%A' via item #%B in list at %0 while it serves as implied-DO iterator at %1", +"Modification of DO-loop iterator `%A' at %0") +FFEBAD_MSGS2 (FFEBAD_TOO_MANY_DIMS, FATAL, +"Array has too many dimensions, as of dimension specifier at %0", +"Too many dimensions at %0") +FFEBAD_MSGS1 (FFEBAD_NULL_ARGUMENT, FATAL, +"Null argument at %0 for statement function reference at %1") +FFEBAD_MSGS1 (FFEBAD_TOO_FEW_ARGUMENTS, FATAL, +"%A too few arguments (starting with dummy argument `%B') as of %0 for statement function reference at %1") +FFEBAD_MSGS1 (FFEBAD_TOO_MANY_ARGUMENTS, FATAL, +"%A too many arguments as of %0 for statement function reference at %1") +FFEBAD_MSGS1 (FFEBAD_ARRAY_AS_SFARG, FATAL, +"Array supplied at %1 for dummy argument `%A' in statement function reference at %0") +FFEBAD_MSGS1 (FFEBAD_FORMAT_UNSUPPORTED, FATAL, +"Unsupported FORMAT specifier at %0") +FFEBAD_MSGS2 (FFEBAD_OPEN_UNSUPPORTED, WARN, +"Unsupported OPEN control item at %0 -- ACTION=, ASSOCIATEVARIABLE=, BLOCKSIZE=, BUFFERCOUNT=, CARRIAGECONTROL=, DEFAULTFILE=, DELIM=, DISPOSE=, EXTENDSIZE=, INITIALSIZE=, KEY=, MAXREC=, NOSPANBLOCKS, ORGANIZATION=, PAD=, POSITION=, READONLY=, RECORDTYPE=, SHARED=, and USEROPEN= are not supported", +"Unsupported OPEN control item at %0") +FFEBAD_MSGS2 (FFEBAD_INQUIRE_UNSUPPORTED, WARN, +"Unsupported INQUIRE control item at %0 -- ACTION=, CARRIAGECONTROL=, DEFAULTFILE=, DELIM=, KEYED=, ORGANIZATION=, PAD=, POSITION=, READ=, READWRITE=, RECORDTYPE=, and WRITE= are not supported", +"Unsupported INQUIRE control item at %0") +FFEBAD_MSGS2 (FFEBAD_READ_UNSUPPORTED, WARN, +"Unsupported READ control item at %0 -- ADVANCE=, EOR=, KEYEQ=, KEYGE=, KEYGT=, KEYID=, NULLS=, and SIZE= are not supported", +"Unsupported READ control item at %0") +FFEBAD_MSGS2 (FFEBAD_WRITE_UNSUPPORTED, WARN, +"Unsupported WRITE control item at %0 -- ADVANCE= and EOR= are not supported", +"Unsupported WRITE control item at %0") +FFEBAD_MSGS1 (FFEBAD_VXT_UNSUPPORTED, FATAL, +"Unsupported VXT statement at %0") +FFEBAD_MSGS1 (FFEBAD_DATA_REINIT, FATAL, +"Attempt to specify second initial value for `%A' at %0") +FFEBAD_MSGS1 (FFEBAD_DATA_TOOFEW, FATAL, +"Too few initial values in list of initializers for `%A' at %0") +FFEBAD_MSGS1 (FFEBAD_DATA_TOOMANY, FATAL, +"Too many initial values in list of initializers starting at %0") +FFEBAD_MSGS1 (FFEBAD_DATA_RANGE, FATAL, +"Array or substring specification for `%A' out of range in statement at %0") +FFEBAD_MSGS1 (FFEBAD_DATA_SUBSCRIPT, FATAL, +"Array subscript #%B out of range for initialization of `%A' in statement at %0") +FFEBAD_MSGS1 (FFEBAD_DATA_ZERO, FATAL, +"Implied do-loop step count of 0 (zero) for iteration variable `%A' in statement at %0") +FFEBAD_MSGS1 (FFEBAD_DATA_EMPTY, FATAL, +"Implied do-loop iteration count of 0 (zero) for iteration variable `%A' in statement at %0") +FFEBAD_MSGS1 (FFEBAD_DATA_EVAL, FATAL, +"Not an integer constant expression in implied do-loop in statement at %0") +FFEBAD_MSGS1 (FFEBAD_DATA_MULTIPLE, FATAL, +"Attempt to specify second initial value for element of `%A' at %0") +FFEBAD_MSGS1 (FFEBAD_EQUIV_COMMON, FATAL, +"Attempt to EQUIVALENCE common areas `%A' and `%B' at %0") +FFEBAD_MSGS1 (FFEBAD_EQUIV_ALIGN, FATAL, +"Can't place `%A' as directed by EQUIVALENCE due to alignment restrictions") +FFEBAD_MSGS1 (FFEBAD_EQUIV_MISMATCH, FATAL, +"Mismatched EQUIVALENCE requirements for placement of `%A' at both %C and %D bytes offset from `%B'") +FFEBAD_MSGS1 (FFEBAD_EQUIV_RANGE, FATAL, +"Array or substring specification for `%A' out of range in EQUIVALENCE statement") +FFEBAD_MSGS1 (FFEBAD_EQUIV_SUBSTR, FATAL, +"Substring of non-CHARACTER entity `%A' in EQUIVALENCE statement") +FFEBAD_MSGS1 (FFEBAD_EQUIV_ARRAY, FATAL, +"Array reference to scalar variable `%A' in EQUIVALENCE statement") +FFEBAD_MSGS1 (FFEBAD_EQUIV_SUBSCRIPT, WARN, +"Array subscript #%B out of range for EQUIVALENCE of `%A'") +FFEBAD_MSGS2 (FFEBAD_COMMON_PAD, WARN, +"Padding of %A %D required before `%B' in common block `%C' at %0 -- consider reordering members, largest-type-size first", +"Padding of %A %D required before `%B' in common block `%C' at %0") +FFEBAD_MSGS1 (FFEBAD_COMMON_NEG, FATAL, +"Attempt to extend COMMON area beyond its starting point via EQUIVALENCE of `%A'") +FFEBAD_MSGS1 (FFEBAD_EQUIV_FEW, FATAL, +"Too few elements in reference to array `%A' in EQUIVALENCE statement") +FFEBAD_MSGS1 (FFEBAD_EQUIV_MANY, FATAL, +"Too many elements in reference to array `%A' in EQUIVALENCE statement") +FFEBAD_MSGS1 (FFEBAD_MIXED_TYPES, WARN, +"Mixed CHARACTER and non-CHARACTER types via COMMON/EQUIVALENCE -- for example, `%A' and `%B'") +FFEBAD_MSGS2 (FFEBAD_IMPLICIT_ADJLEN, FATAL, +"Invalid length specification at %0 for IMPLICIT statement -- must be integer constant expression", +"Invalid length specification at %0") +FFEBAD_MSGS2 (FFEBAD_ENTRY_CONFLICTS, FATAL, +"Type of ENTRY point at %0 to function conflicts with type(s) of previous entrypoint(s) -- must all be identical-length CHARACTER or none be CHARACTER type", +"Type of ENTRY point at %0 to function conflicts with type(s) of previous entrypoint(s)") +FFEBAD_MSGS1 (FFEBAD_RETURN_VALUE_UNSET, WARN, +"Return value `%A' for FUNCTION at %0 not referenced in subprogram") +FFEBAD_MSGS2 (FFEBAD_COMMON_ALREADY_INIT, FATAL, +"Common block `%A' initialized at %0 already initialized at %1 -- only one program unit may specify initial values for a particular common block", +"Common block `%A' initialized at %0 already initialized at %1") +FFEBAD_MSGS2 (FFEBAD_COMMON_INIT_PAD, WARN, +"Initial padding for common block `%A' is %B %C at %0 -- consider reordering members, largest-type-size first", +"Initial padding for common block `%A' is %B %C at %0") +FFEBAD_MSGS2 (FFEBAD_COMMON_DIFF_PAD, FATAL, +"Initial padding for common block `%A' is %B %D at %0 but %C %E at %1 -- consider reordering members, largest-type-size first", +"Initial padding for common block `%A' is %B %D at %0 but %C %E at %1") +FFEBAD_MSGS1 (FFEBAD_COMMON_DIFF_SAVE, WARN, +"Common block `%A' is SAVEd, explicitly or implicitly, at %0 but not SAVEd at %1") +FFEBAD_MSGS1 (FFEBAD_COMMON_DIFF_SIZE, WARN, +"Common block `%A' is %B %D in length at %0 but %C %E at %1") +FFEBAD_MSGS2 (FFEBAD_COMMON_ENLARGED, FATAL, +"Common block `%A' is initialized to %B %D long at %0 but enlarged to %C %E at %1 -- use consistent definitions or reorder program units in source file", +"Common block `%A' is initialized to %B %D long at %0 but enlarged to %C %E at %1") +FFEBAD_MSGS1 (FFEBAD_COMMON_BLANK_INIT, WARN, +"Blank common initialized at %0") +FFEBAD_MSGS1 (FFEBAD_NEED_INTRINSIC, WARN, +"Intrinsic `%A' is passed as actual argument at %0 but not explicitly declared INTRINSIC") +FFEBAD_MSGS1 (FFEBAD_NEED_EXTERNAL, WARN, +"External procedure `%A' is passed as actual argument at %0 but not explicitly declared EXTERNAL") +FFEBAD_MSGS1 (FFEBAD_SYMBOL_UPPER_CASE, WARN, +"Character `%A' (for example) is upper-case in symbol name at %0") +FFEBAD_MSGS1 (FFEBAD_SYMBOL_LOWER_CASE, WARN, +"Character `%A' (for example) is lower-case in symbol name at %0") +FFEBAD_MSGS1 (FFEBAD_SYMBOL_NOLOWER_INITCAP, WARN, +"Character `%A' not followed at some point by lower-case character in symbol name at %0") +FFEBAD_MSGS1 (FFEBAD_SYMBOL_LOWER_INITCAP, WARN, +"Initial character `%A' is lower-case in symbol name at %0") +FFEBAD_MSGS2 (FFEBAD_DO_REAL, WARN, +"DO-variable `%A' is type REAL or DOUBLE PRECISION at %0 -- unexpected behavior likely", +"DO-variable `%A' is type REAL or DOUBLE PRECISION at %0") +FFEBAD_MSGS1 (FFEBAD_NAMELIST_CASE, WARN, +"NAMELIST not adequately supported by run-time library for source files with case preserved") +FFEBAD_MSGS1 (FFEBAD_NESTED_PERCENT, WARN, +"Nested %% construct (%%VAL, %%REF, or %%DESCR) at %0") +FFEBAD_MSGS2 (FFEBAD_ACTUALARG, WARN, +"Invalid actual argument at %0 -- replace hollerith constants with %%REF('string') and typeless constants with INTEGER constant equivalents, or use -fugly-args or -fugly", +"Invalid actual argument at %0") +FFEBAD_MSGS2 (FFEBAD_QUAD_UNSUPPORTED, WARN, +"Quadruple-precision floating-point unsupported -- treating constant at %0 as double-precision", +"Quadruple-precision floating-point unsupported") +FFEBAD_MSGS2 (FFEBAD_TOO_BIG_INIT, WARN, +"Initialization of large (%B-unit) aggregate area `%A' at %0 currently very slow and takes lots of memory during g77 compile -- to be improved in 0.6", +"This could take a while (initializing `%A' at %0)...") +FFEBAD_MSGS1 (FFEBAD_BLOCKDATA_STMT, WARN, +"Statement at %0 invalid in BLOCK DATA program unit at %1") +FFEBAD_MSGS1 (FFEBAD_TRUNCATING_CHARACTER, WARN, +"Truncating characters on right side of character constant at %0") +FFEBAD_MSGS1 (FFEBAD_TRUNCATING_HOLLERITH, WARN, +"Truncating characters on right side of hollerith constant at %0") +FFEBAD_MSGS1 (FFEBAD_TRUNCATING_NUMERIC, WARN, +"Truncating non-zero data on left side of numeric constant at %0") +FFEBAD_MSGS1 (FFEBAD_TRUNCATING_TYPELESS, WARN, +"Truncating non-zero data on left side of typeless constant at %0") +FFEBAD_MSGS1 (FFEBAD_TYPELESS_OVERFLOW, WARN, +"Typeless constant at %0 too large") +FFEBAD_MSGS1 (FFEBAD_AMPERSAND, WARN, +"First-column ampersand continuation at %0") +FFEBAD_MSGS1 (FFEBAD_FILEWIDE_ALREADY_SEEN, FATAL, +"Global name `%A' defined at %0 already defined at %1 [info -f g77 M GLOBALS]") +FFEBAD_MSGS1 (FFEBAD_FILEWIDE_ALREADY_SEEN_W, WARN, +"Global name `%A' defined at %0 already defined at %1 [info -f g77 M GLOBALS]") +FFEBAD_MSGS1 (FFEBAD_FILEWIDE_DISAGREEMENT, FATAL, +"Global name `%A' is %B at %0 but is %C at %1 [info -f g77 M GLOBALS]") +FFEBAD_MSGS1 (FFEBAD_FILEWIDE_DISAGREEMENT_W, WARN, +"Global name `%A' is %B at %0 but is %C at %1 [info -f g77 M GLOBALS]") +FFEBAD_MSGS1 (FFEBAD_FILEWIDE_TYPE_MISMATCH, FATAL, +"Global name `%A' at %0 has different type at %1 [info -f g77 M GLOBALS]") +FFEBAD_MSGS1 (FFEBAD_FILEWIDE_TYPE_MISMATCH_W, WARN, +"Global name `%A' at %0 has different type at %1 [info -f g77 M GLOBALS]") +FFEBAD_MSGS1 (FFEBAD_FILEWIDE_NARGS, FATAL, +"Too %B arguments passed to `%A' at %0 versus definition at %1 [info -f g77 M GLOBALS]") +FFEBAD_MSGS1 (FFEBAD_FILEWIDE_NARGS_W, WARN, +"Too %B arguments for `%A' at %0 versus invocation at %1 [info -f g77 M GLOBALS]") +FFEBAD_MSGS1 (FFEBAD_FILEWIDE_ARG, FATAL, +"Argument #%B of `%A' is %C at %0 but is %D at %1 [info -f g77 M GLOBALS]") +FFEBAD_MSGS1 (FFEBAD_FILEWIDE_ARG_W, WARN, +"Argument #%B of `%A' is %C at %0 but is %D at %1 [info -f g77 M GLOBALS]") +FFEBAD_MSGS1 (FFEBAD_ARRAY_LARGE, FATAL, +"Array `%A' at %0 is too large to handle") + +#undef INFORM +#undef TRIVIAL +#undef WARN +#undef PECULIAR +#undef FATAL +#undef WEIRD +#undef SEVERE +#undef DISASTER diff --git a/gcc/f/bad.h b/gcc/f/bad.h new file mode 100644 index 000000000000..cdbf32c007c7 --- /dev/null +++ b/gcc/f/bad.h @@ -0,0 +1,108 @@ +/* bad.h -- Public #include File (module.h template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + bad.c + + Modifications: +*/ + +/* Allow multiple inclusion to work. */ + +#ifndef _H_f_bad +#define _H_f_bad + +/* Simple definitions and enumerations. */ + +typedef enum + { +#define FFEBAD_MSGS1(KWD,SEV,MSG) KWD, +#define FFEBAD_MSGS2(KWD,SEV,LMSG,SMSG) KWD, +#include "bad.def" +#undef FFEBAD_MSGS1 +#undef FFEBAD_MSGS2 + FFEBAD + } ffebad; + +typedef enum + { + + /* Order important; must be increasing severity. */ + + FFEBAD_severityINFORMATIONAL, /* User notice. */ + FFEBAD_severityTRIVIAL, /* Internal notice. */ + FFEBAD_severityWARNING, /* User warning. */ + FFEBAD_severityPECULIAR, /* Internal warning. */ + FFEBAD_severityPEDANTIC, /* Pedantic, could be warning or error. */ + FFEBAD_severityFATAL, /* User error. */ + FFEBAD_severityWEIRD, /* Internal error. */ + FFEBAD_severitySEVERE, /* User error, cannot continue. */ + FFEBAD_severityDISASTER, /* Internal error, cannot continue. */ + FFEBAD_severity + } ffebadSeverity; + +/* Typedefs. */ + +typedef unsigned char ffebadIndex; + +/* Include files needed by this one. */ + +#include "where.h" + +/* Structure definitions. */ + + +/* Global objects accessed by users of this module. */ + +extern bool ffebad_is_inhibited_; + +/* Declare functions with prototypes. */ + +void ffebad_finish (void); +void ffebad_here (ffebadIndex i, ffewhereLine wl, ffewhereColumn wc); +void ffebad_init_0 (void); +bool ffebad_is_fatal (ffebad errnum); +ffebadSeverity ffebad_severity (ffebad errnum); +bool ffebad_start_ (bool lex_override, ffebad errnum, ffebadSeverity sev, + char *message); +void ffebad_string (char *string); + +/* Define macros. */ + +#define ffebad_inhibit() (ffebad_is_inhibited_) +#define ffebad_init_1() +#define ffebad_init_2() +#define ffebad_init_3() +#define ffebad_init_4() +#define ffebad_set_inhibit(f) (ffebad_is_inhibited_ = (f)) +#define ffebad_start(e) ffebad_start_ (FALSE, (e), FFEBAD_severity, NULL) +#define ffebad_start_lex(e) ffebad_start_ (TRUE, (e), FFEBAD_severity, NULL) +#define ffebad_start_msg(m,s) ffebad_start_ (FALSE, FFEBAD, (s), (m)) +#define ffebad_start_msg_lex(m,s) ffebad_start_ (TRUE, FFEBAD, (s), (m)) +#define ffebad_terminate_0() +#define ffebad_terminate_1() +#define ffebad_terminate_2() +#define ffebad_terminate_3() +#define ffebad_terminate_4() + +/* End of #include file. */ + +#endif diff --git a/gcc/f/bit.c b/gcc/f/bit.c new file mode 100644 index 000000000000..864d601665b7 --- /dev/null +++ b/gcc/f/bit.c @@ -0,0 +1,201 @@ +/* bit.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + None + + Description: + Tracks arrays of booleans in useful ways. + + Modifications: +*/ + +/* Include files. */ + +#include "proj.h" +#include "glimits.j" +#include "bit.h" +#include "malloc.h" + +/* Externals defined here. */ + + +/* Simple definitions and enumerations. */ + + +/* Internal typedefs. */ + + +/* Private include files. */ + + +/* Internal structure definitions. */ + + +/* Static objects accessed by functions in this module. */ + + +/* Static functions (internal). */ + + +/* Internal macros. */ + + +/* ffebit_count -- Count # of bits set a particular way + + ffebit b; // the ffebit object + ffebitCount offset; // 0..size-1 + bool value; // FALSE (0), TRUE (1) + ffebitCount range; // # bits to test + ffebitCount number; // # bits equal to value + ffebit_count(b,offset,value,range,&number); + + Sets to # bits at through set to + . If is 0, is set to 0. */ + +void +ffebit_count (ffebit b, ffebitCount offset, bool value, ffebitCount range, + ffebitCount *number) +{ + ffebitCount element; + ffebitCount bitno; + + assert (offset + range <= b->size); + + for (*number = 0; range != 0; --range, ++offset) + { + element = offset / CHAR_BIT; + bitno = offset % CHAR_BIT; + if (value + == ((b->bits[element] & ((unsigned char) 1 << bitno)) == 0 ? FALSE : TRUE)) + ++ * number; + } +} + +/* ffebit_new -- Create a new ffebit object + + ffebit b; + ffebit_kill(b); + + Destroys an ffebit object obtained via ffebit_new. */ + +void +ffebit_kill (ffebit b) +{ + malloc_kill_ks (b->pool, b, + offsetof (struct _ffebit_, bits) + + (b->size + CHAR_BIT - 1) / CHAR_BIT); +} + +/* ffebit_new -- Create a new ffebit object + + ffebit b; + mallocPool pool; + ffebitCount size; + b = ffebit_new(pool,size); + + Allocates an ffebit object that holds the values of bits in pool + . */ + +ffebit +ffebit_new (mallocPool pool, ffebitCount size) +{ + ffebit b; + + b = malloc_new_zks (pool, "ffebit", + offsetof (struct _ffebit_, bits) + + (size + CHAR_BIT - 1) / CHAR_BIT, + 0); + b->pool = pool; + b->size = size; + + return b; +} + +/* ffebit_set -- Set value of # of bits + + ffebit b; // the ffebit object + ffebitCount offset; // 0..size-1 + bool value; // FALSE (0), TRUE (1) + ffebitCount length; // # bits to set starting at offset (usually 1) + ffebit_set(b,offset,value,length); + + Sets bit #s through to . */ + +void +ffebit_set (ffebit b, ffebitCount offset, bool value, ffebitCount length) +{ + ffebitCount i; + ffebitCount element; + ffebitCount bitno; + + assert (offset + length <= b->size); + + for (i = 0; i < length; ++i, ++offset) + { + element = offset / CHAR_BIT; + bitno = offset % CHAR_BIT; + b->bits[element] = (((unsigned char) (value ? 1 : 0)) << bitno) + | (b->bits[element] & ~((unsigned char) 1 << bitno)); + } +} + +/* ffebit_test -- Test value of # of bits + + ffebit b; // the ffebit object + ffebitCount offset; // 0..size-1 + bool value; // FALSE (0), TRUE (1) + ffebitCount length; // # bits with same value + ffebit_test(b,offset,&value,&length); + + Returns value of bits at through in + . If is already at the end of the bit array (if + offset == ffebit_size(b)), is set to 0 and is + undefined. */ + +void +ffebit_test (ffebit b, ffebitCount offset, bool *value, ffebitCount *length) +{ + ffebitCount i; + ffebitCount element; + ffebitCount bitno; + + if (offset >= b->size) + { + assert (offset == b->size); + *length = 0; + return; + } + + element = offset / CHAR_BIT; + bitno = offset % CHAR_BIT; + *value = (b->bits[element] & ((unsigned char) 1 << bitno)) == 0 ? FALSE : TRUE; + *length = 1; + + for (i = b->size - offset - 1, ++offset; i != 0; --i, ++offset, ++*length) + { + element = offset / CHAR_BIT; + bitno = offset % CHAR_BIT; + if (*value + != ((b->bits[element] & ((unsigned char) 1 << bitno)) == 0 ? FALSE : TRUE)) + break; + } +} diff --git a/gcc/f/bit.h b/gcc/f/bit.h new file mode 100644 index 000000000000..cb7357fa1bb6 --- /dev/null +++ b/gcc/f/bit.h @@ -0,0 +1,84 @@ +/* bit.h -- Public #include File (module.h template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + bit.c + + Modifications: +*/ + +/* Allow multiple inclusion to work. */ + +#ifndef _H_f_bit +#define _H_f_bit + +/* Simple definitions and enumerations. */ + + +/* Typedefs. */ + +typedef struct _ffebit_ *ffebit; +typedef unsigned long ffebitCount; +#define ffebitCount_f "l" + +/* Include files needed by this one. */ + +#include "malloc.h" + +/* Structure definitions. */ + +struct _ffebit_ + { + mallocPool pool; + ffebitCount size; + unsigned char bits[1]; + }; + +/* Global objects accessed by users of this module. */ + + +/* Declare functions with prototypes. */ + +void ffebit_count (ffebit b, ffebitCount offset, bool value, ffebitCount range, + ffebitCount *number); +void ffebit_kill (ffebit b); +ffebit ffebit_new (mallocPool pool, ffebitCount size); +void ffebit_set (ffebit b, ffebitCount offset, bool value, ffebitCount length); +void ffebit_test (ffebit b, ffebitCount offset, bool *value, ffebitCount *length); + +/* Define macros. */ + +#define ffebit_init_0() +#define ffebit_init_1() +#define ffebit_init_2() +#define ffebit_init_3() +#define ffebit_init_4() +#define ffebit_pool(b) ((b)->pool) +#define ffebit_size(b) ((b)->size) +#define ffebit_terminate_0() +#define ffebit_terminate_1() +#define ffebit_terminate_2() +#define ffebit_terminate_3() +#define ffebit_terminate_4() + +/* End of #include file. */ + +#endif diff --git a/gcc/f/bld-op.def b/gcc/f/bld-op.def new file mode 100644 index 000000000000..adaec06673cf --- /dev/null +++ b/gcc/f/bld-op.def @@ -0,0 +1,69 @@ +/* bld-op.def -- Public #include File (module.h template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + bad.c + + Modifications: +*/ + +FFEBLD_OP (FFEBLD_opANY, "ANY", 0) +FFEBLD_OP (FFEBLD_opSTAR, "STAR", 0) /* For adjustable arrays, alternate return dummies, etc. */ +FFEBLD_OP (FFEBLD_opCONTER, "CONTER", 0) +FFEBLD_OP (FFEBLD_opARRTER, "ARRTER", 0) /* Array of constants (DATA...). */ +FFEBLD_OP (FFEBLD_opACCTER, "ACCTER", 0) /* Accreting ARRTER. */ +FFEBLD_OP (FFEBLD_opSYMTER, "SYMTER", 0) +FFEBLD_OP (FFEBLD_opITEM, "ITEM", 0) +FFEBLD_OP (FFEBLD_opUPLUS, "UPLUS", 1) +FFEBLD_OP (FFEBLD_opUMINUS, "UMINUS", 1) +FFEBLD_OP (FFEBLD_opADD, "ADD", 2) +FFEBLD_OP (FFEBLD_opSUBTRACT, "SUBTRACT", 2) +FFEBLD_OP (FFEBLD_opMULTIPLY, "MULTIPLY", 2) +FFEBLD_OP (FFEBLD_opDIVIDE, "DIVIDE", 2) +FFEBLD_OP (FFEBLD_opPOWER, "POWER", 2) +FFEBLD_OP (FFEBLD_opCONCATENATE, "CONCATENATE", 2) +FFEBLD_OP (FFEBLD_opNOT, "NOT", 1) +FFEBLD_OP (FFEBLD_opLT, "LT", 2) +FFEBLD_OP (FFEBLD_opLE, "LE", 2) +FFEBLD_OP (FFEBLD_opEQ, "EQ", 2) +FFEBLD_OP (FFEBLD_opNE, "NE", 2) +FFEBLD_OP (FFEBLD_opGT, "GT", 2) +FFEBLD_OP (FFEBLD_opGE, "GE", 2) +FFEBLD_OP (FFEBLD_opAND, "AND", 2) +FFEBLD_OP (FFEBLD_opOR, "OR", 2) +FFEBLD_OP (FFEBLD_opXOR, "XOR", 2) +FFEBLD_OP (FFEBLD_opEQV, "EQV", 2) +FFEBLD_OP (FFEBLD_opNEQV, "NEQV", 2) +FFEBLD_OP (FFEBLD_opPAREN, "PAREN", 1) +FFEBLD_OP (FFEBLD_opPERCENT_LOC, "%LOC", 1) +FFEBLD_OP (FFEBLD_opPERCENT_VAL, "%VAL", 1) +FFEBLD_OP (FFEBLD_opPERCENT_REF, "%REF", 1) +FFEBLD_OP (FFEBLD_opPERCENT_DESCR, "%DESCR", 1) +FFEBLD_OP (FFEBLD_opCONVERT, "CONVERT", 1) +FFEBLD_OP (FFEBLD_opREPEAT, "REPEAT", 2) +FFEBLD_OP (FFEBLD_opBOUNDS, "BOUNDS", 2) /* For low:high in dimension lists. */ +FFEBLD_OP (FFEBLD_opFUNCREF, "FUNCREF", 2) +FFEBLD_OP (FFEBLD_opSUBRREF, "SUBRREF", 2) +FFEBLD_OP (FFEBLD_opARRAYREF, "ARRAYREF", 2) +FFEBLD_OP (FFEBLD_opSUBSTR, "SUBSTR", 2) +FFEBLD_OP (FFEBLD_opLABTER, "LABTER", 0) +FFEBLD_OP (FFEBLD_opLABTOK, "LABTOK", 0) /* Like LABTER but contains ffelexToken instead. */ +FFEBLD_OP (FFEBLD_opIMPDO, "IMPDO", 2) diff --git a/gcc/f/bld.c b/gcc/f/bld.c new file mode 100644 index 000000000000..3a95727adc1f --- /dev/null +++ b/gcc/f/bld.c @@ -0,0 +1,5782 @@ +/* bld.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995, 1996 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + None + + Description: + The primary "output" of the FFE includes ffebld objects, which + connect expressions, operators, and operands together, along with + connecting lists of expressions together for argument or dimension + lists. + + Modifications: + 30-Aug-92 JCB 1.1 + Change names of some things for consistency. +*/ + +/* Include files. */ + +#include "proj.h" +#include +#include "bld.h" +#include "bit.h" +#include "info.h" +#include "lex.h" +#include "malloc.h" +#include "target.h" +#include "where.h" + +/* Externals defined here. */ + +ffebldArity ffebld_arity_op_[] += +{ +#define FFEBLD_OP(KWD,NAME,ARITY) ARITY, +#include "bld-op.def" +#undef FFEBLD_OP +}; +struct _ffebld_pool_stack_ ffebld_pool_stack_; + +/* Simple definitions and enumerations. */ + + +/* Internal typedefs. */ + + +/* Private include files. */ + + +/* Internal structure definitions. */ + + +/* Static objects accessed by functions in this module. */ + +#if FFEBLD_BLANK_ +static struct _ffebld_ ffebld_blank_ += +{ + 0, + {FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0, FFEINFO_kindNONE, + FFEINFO_whereNONE, FFETARGET_charactersizeNONE}, + {NULL, NULL} +}; +#endif +#if FFETARGET_okCHARACTER1 +static ffebldConstant ffebld_constant_character1_; +#endif +#if FFETARGET_okCHARACTER2 +static ffebldConstant ffebld_constant_character2_; +#endif +#if FFETARGET_okCHARACTER3 +static ffebldConstant ffebld_constant_character3_; +#endif +#if FFETARGET_okCHARACTER4 +static ffebldConstant ffebld_constant_character4_; +#endif +#if FFETARGET_okCHARACTER5 +static ffebldConstant ffebld_constant_character5_; +#endif +#if FFETARGET_okCHARACTER6 +static ffebldConstant ffebld_constant_character6_; +#endif +#if FFETARGET_okCHARACTER7 +static ffebldConstant ffebld_constant_character7_; +#endif +#if FFETARGET_okCHARACTER8 +static ffebldConstant ffebld_constant_character8_; +#endif +#if FFETARGET_okCOMPLEX1 +static ffebldConstant ffebld_constant_complex1_; +#endif +#if FFETARGET_okCOMPLEX2 +static ffebldConstant ffebld_constant_complex2_; +#endif +#if FFETARGET_okCOMPLEX3 +static ffebldConstant ffebld_constant_complex3_; +#endif +#if FFETARGET_okCOMPLEX4 +static ffebldConstant ffebld_constant_complex4_; +#endif +#if FFETARGET_okCOMPLEX5 +static ffebldConstant ffebld_constant_complex5_; +#endif +#if FFETARGET_okCOMPLEX6 +static ffebldConstant ffebld_constant_complex6_; +#endif +#if FFETARGET_okCOMPLEX7 +static ffebldConstant ffebld_constant_complex7_; +#endif +#if FFETARGET_okCOMPLEX8 +static ffebldConstant ffebld_constant_complex8_; +#endif +#if FFETARGET_okINTEGER1 +static ffebldConstant ffebld_constant_integer1_; +#endif +#if FFETARGET_okINTEGER2 +static ffebldConstant ffebld_constant_integer2_; +#endif +#if FFETARGET_okINTEGER3 +static ffebldConstant ffebld_constant_integer3_; +#endif +#if FFETARGET_okINTEGER4 +static ffebldConstant ffebld_constant_integer4_; +#endif +#if FFETARGET_okINTEGER5 +static ffebldConstant ffebld_constant_integer5_; +#endif +#if FFETARGET_okINTEGER6 +static ffebldConstant ffebld_constant_integer6_; +#endif +#if FFETARGET_okINTEGER7 +static ffebldConstant ffebld_constant_integer7_; +#endif +#if FFETARGET_okINTEGER8 +static ffebldConstant ffebld_constant_integer8_; +#endif +#if FFETARGET_okLOGICAL1 +static ffebldConstant ffebld_constant_logical1_; +#endif +#if FFETARGET_okLOGICAL2 +static ffebldConstant ffebld_constant_logical2_; +#endif +#if FFETARGET_okLOGICAL3 +static ffebldConstant ffebld_constant_logical3_; +#endif +#if FFETARGET_okLOGICAL4 +static ffebldConstant ffebld_constant_logical4_; +#endif +#if FFETARGET_okLOGICAL5 +static ffebldConstant ffebld_constant_logical5_; +#endif +#if FFETARGET_okLOGICAL6 +static ffebldConstant ffebld_constant_logical6_; +#endif +#if FFETARGET_okLOGICAL7 +static ffebldConstant ffebld_constant_logical7_; +#endif +#if FFETARGET_okLOGICAL8 +static ffebldConstant ffebld_constant_logical8_; +#endif +#if FFETARGET_okREAL1 +static ffebldConstant ffebld_constant_real1_; +#endif +#if FFETARGET_okREAL2 +static ffebldConstant ffebld_constant_real2_; +#endif +#if FFETARGET_okREAL3 +static ffebldConstant ffebld_constant_real3_; +#endif +#if FFETARGET_okREAL4 +static ffebldConstant ffebld_constant_real4_; +#endif +#if FFETARGET_okREAL5 +static ffebldConstant ffebld_constant_real5_; +#endif +#if FFETARGET_okREAL6 +static ffebldConstant ffebld_constant_real6_; +#endif +#if FFETARGET_okREAL7 +static ffebldConstant ffebld_constant_real7_; +#endif +#if FFETARGET_okREAL8 +static ffebldConstant ffebld_constant_real8_; +#endif +static ffebldConstant ffebld_constant_hollerith_; +static ffebldConstant ffebld_constant_typeless_[FFEBLD_constTYPELESS_LAST + - FFEBLD_constTYPELESS_FIRST + 1]; + +static char *ffebld_op_string_[] += +{ +#define FFEBLD_OP(KWD,NAME,ARITY) NAME, +#include "bld-op.def" +#undef FFEBLD_OP +}; + +/* Static functions (internal). */ + + +/* Internal macros. */ + +#define integerdefault_ CATX(integer,FFETARGET_ktINTEGERDEFAULT) +#define logicaldefault_ CATX(logical,FFETARGET_ktLOGICALDEFAULT) +#define realdefault_ CATX(real,FFETARGET_ktREALDEFAULT) +#define realdouble_ CATX(real,FFETARGET_ktREALDOUBLE) +#define realquad_ CATX(real,FFETARGET_ktREALQUAD) + +/* ffebld_constant_cmp -- Compare two constants a la strcmp + + ffebldConstant c1, c2; + if (ffebld_constant_cmp(c1,c2) == 0) + // they're equal, else they're not. + + Returns -1 if c1 < c2, 0 if c1 == c2, +1 if c1 == c2. */ + +int +ffebld_constant_cmp (ffebldConstant c1, ffebldConstant c2) +{ + if (c1 == c2) + return 0; + + assert (ffebld_constant_type (c1) == ffebld_constant_type (c2)); + + switch (ffebld_constant_type (c1)) + { +#if FFETARGET_okINTEGER1 + case FFEBLD_constINTEGER1: + return ffetarget_cmp_integer1 (ffebld_constant_integer1 (c1), + ffebld_constant_integer1 (c2)); +#endif + +#if FFETARGET_okINTEGER2 + case FFEBLD_constINTEGER2: + return ffetarget_cmp_integer2 (ffebld_constant_integer2 (c1), + ffebld_constant_integer2 (c2)); +#endif + +#if FFETARGET_okINTEGER3 + case FFEBLD_constINTEGER3: + return ffetarget_cmp_integer3 (ffebld_constant_integer3 (c1), + ffebld_constant_integer3 (c2)); +#endif + +#if FFETARGET_okINTEGER4 + case FFEBLD_constINTEGER4: + return ffetarget_cmp_integer4 (ffebld_constant_integer4 (c1), + ffebld_constant_integer4 (c2)); +#endif + +#if FFETARGET_okINTEGER5 + case FFEBLD_constINTEGER5: + return ffetarget_cmp_integer5 (ffebld_constant_integer5 (c1), + ffebld_constant_integer5 (c2)); +#endif + +#if FFETARGET_okINTEGER6 + case FFEBLD_constINTEGER6: + return ffetarget_cmp_integer6 (ffebld_constant_integer6 (c1), + ffebld_constant_integer6 (c2)); +#endif + +#if FFETARGET_okINTEGER7 + case FFEBLD_constINTEGER7: + return ffetarget_cmp_integer7 (ffebld_constant_integer7 (c1), + ffebld_constant_integer7 (c2)); +#endif + +#if FFETARGET_okINTEGER8 + case FFEBLD_constINTEGER8: + return ffetarget_cmp_integer8 (ffebld_constant_integer8 (c1), + ffebld_constant_integer8 (c2)); +#endif + +#if FFETARGET_okLOGICAL1 + case FFEBLD_constLOGICAL1: + return ffetarget_cmp_logical1 (ffebld_constant_logical1 (c1), + ffebld_constant_logical1 (c2)); +#endif + +#if FFETARGET_okLOGICAL2 + case FFEBLD_constLOGICAL2: + return ffetarget_cmp_logical2 (ffebld_constant_logical2 (c1), + ffebld_constant_logical2 (c2)); +#endif + +#if FFETARGET_okLOGICAL3 + case FFEBLD_constLOGICAL3: + return ffetarget_cmp_logical3 (ffebld_constant_logical3 (c1), + ffebld_constant_logical3 (c2)); +#endif + +#if FFETARGET_okLOGICAL4 + case FFEBLD_constLOGICAL4: + return ffetarget_cmp_logical4 (ffebld_constant_logical4 (c1), + ffebld_constant_logical4 (c2)); +#endif + +#if FFETARGET_okLOGICAL5 + case FFEBLD_constLOGICAL5: + return ffetarget_cmp_logical5 (ffebld_constant_logical5 (c1), + ffebld_constant_logical5 (c2)); +#endif + +#if FFETARGET_okLOGICAL6 + case FFEBLD_constLOGICAL6: + return ffetarget_cmp_logical6 (ffebld_constant_logical6 (c1), + ffebld_constant_logical6 (c2)); +#endif + +#if FFETARGET_okLOGICAL7 + case FFEBLD_constLOGICAL7: + return ffetarget_cmp_logical7 (ffebld_constant_logical7 (c1), + ffebld_constant_logical7 (c2)); +#endif + +#if FFETARGET_okLOGICAL8 + case FFEBLD_constLOGICAL8: + return ffetarget_cmp_logical8 (ffebld_constant_logical8 (c1), + ffebld_constant_logical8 (c2)); +#endif + +#if FFETARGET_okREAL1 + case FFEBLD_constREAL1: + return ffetarget_cmp_real1 (ffebld_constant_real1 (c1), + ffebld_constant_real1 (c2)); +#endif + +#if FFETARGET_okREAL2 + case FFEBLD_constREAL2: + return ffetarget_cmp_real2 (ffebld_constant_real2 (c1), + ffebld_constant_real2 (c2)); +#endif + +#if FFETARGET_okREAL3 + case FFEBLD_constREAL3: + return ffetarget_cmp_real3 (ffebld_constant_real3 (c1), + ffebld_constant_real3 (c2)); +#endif + +#if FFETARGET_okREAL4 + case FFEBLD_constREAL4: + return ffetarget_cmp_real4 (ffebld_constant_real4 (c1), + ffebld_constant_real4 (c2)); +#endif + +#if FFETARGET_okREAL5 + case FFEBLD_constREAL5: + return ffetarget_cmp_real5 (ffebld_constant_real5 (c1), + ffebld_constant_real5 (c2)); +#endif + +#if FFETARGET_okREAL6 + case FFEBLD_constREAL6: + return ffetarget_cmp_real6 (ffebld_constant_real6 (c1), + ffebld_constant_real6 (c2)); +#endif + +#if FFETARGET_okREAL7 + case FFEBLD_constREAL7: + return ffetarget_cmp_real7 (ffebld_constant_real7 (c1), + ffebld_constant_real7 (c2)); +#endif + +#if FFETARGET_okREAL8 + case FFEBLD_constREAL8: + return ffetarget_cmp_real8 (ffebld_constant_real8 (c1), + ffebld_constant_real8 (c2)); +#endif + +#if FFETARGET_okCHARACTER1 + case FFEBLD_constCHARACTER1: + return ffetarget_cmp_character1 (ffebld_constant_character1 (c1), + ffebld_constant_character1 (c2)); +#endif + +#if FFETARGET_okCHARACTER2 + case FFEBLD_constCHARACTER2: + return ffetarget_cmp_character2 (ffebld_constant_character2 (c1), + ffebld_constant_character2 (c2)); +#endif + +#if FFETARGET_okCHARACTER3 + case FFEBLD_constCHARACTER3: + return ffetarget_cmp_character3 (ffebld_constant_character3 (c1), + ffebld_constant_character3 (c2)); +#endif + +#if FFETARGET_okCHARACTER4 + case FFEBLD_constCHARACTER4: + return ffetarget_cmp_character4 (ffebld_constant_character4 (c1), + ffebld_constant_character4 (c2)); +#endif + +#if FFETARGET_okCHARACTER5 + case FFEBLD_constCHARACTER5: + return ffetarget_cmp_character5 (ffebld_constant_character5 (c1), + ffebld_constant_character5 (c2)); +#endif + +#if FFETARGET_okCHARACTER6 + case FFEBLD_constCHARACTER6: + return ffetarget_cmp_character6 (ffebld_constant_character6 (c1), + ffebld_constant_character6 (c2)); +#endif + +#if FFETARGET_okCHARACTER7 + case FFEBLD_constCHARACTER7: + return ffetarget_cmp_character7 (ffebld_constant_character7 (c1), + ffebld_constant_character7 (c2)); +#endif + +#if FFETARGET_okCHARACTER8 + case FFEBLD_constCHARACTER8: + return ffetarget_cmp_character8 (ffebld_constant_character8 (c1), + ffebld_constant_character8 (c2)); +#endif + + default: + assert ("bad constant type" == NULL); + return 0; + } +} + +/* ffebld_constant_dump -- Display summary of constant's contents + + ffebldConstant c; + ffebld_constant_dump(c); + + Displays the constant in summary form. */ + +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; + } +} + +/* ffebld_constant_is_magical -- Determine if integer is "magical" + + ffebldConstant c; + if (ffebld_constant_is_magical(c)) + // it is 2**(n-1), where n is # bits in ffetargetIntegerDefault type + // (this test is important for 2's-complement machines only). */ + +bool +ffebld_constant_is_magical (ffebldConstant c) +{ + switch (ffebld_constant_type (c)) + { + case FFEBLD_constINTEGERDEFAULT: + return ffetarget_integerdefault_is_magical (ffebld_constant_integer1 (c)); + + default: + return FALSE; + } +} + +/* Determine if constant is zero. Used to ensure step count + for DO loops isn't zero, also to determine if values will + be binary zeros, so not entirely portable at this point. */ + +bool +ffebld_constant_is_zero (ffebldConstant c) +{ + switch (ffebld_constant_type (c)) + { +#if FFETARGET_okINTEGER1 + case FFEBLD_constINTEGER1: + return ffebld_constant_integer1 (c) == 0; +#endif + +#if FFETARGET_okINTEGER2 + case FFEBLD_constINTEGER2: + return ffebld_constant_integer2 (c) == 0; +#endif + +#if FFETARGET_okINTEGER3 + case FFEBLD_constINTEGER3: + return ffebld_constant_integer3 (c) == 0; +#endif + +#if FFETARGET_okINTEGER4 + case FFEBLD_constINTEGER4: + return ffebld_constant_integer4 (c) == 0; +#endif + +#if FFETARGET_okINTEGER5 + case FFEBLD_constINTEGER5: + return ffebld_constant_integer5 (c) == 0; +#endif + +#if FFETARGET_okINTEGER6 + case FFEBLD_constINTEGER6: + return ffebld_constant_integer6 (c) == 0; +#endif + +#if FFETARGET_okINTEGER7 + case FFEBLD_constINTEGER7: + return ffebld_constant_integer7 (c) == 0; +#endif + +#if FFETARGET_okINTEGER8 + case FFEBLD_constINTEGER8: + return ffebld_constant_integer8 (c) == 0; +#endif + +#if FFETARGET_okLOGICAL1 + case FFEBLD_constLOGICAL1: + return ffebld_constant_logical1 (c) == 0; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEBLD_constLOGICAL2: + return ffebld_constant_logical2 (c) == 0; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEBLD_constLOGICAL3: + return ffebld_constant_logical3 (c) == 0; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEBLD_constLOGICAL4: + return ffebld_constant_logical4 (c) == 0; +#endif + +#if FFETARGET_okLOGICAL5 + case FFEBLD_constLOGICAL5: + return ffebld_constant_logical5 (c) == 0; +#endif + +#if FFETARGET_okLOGICAL6 + case FFEBLD_constLOGICAL6: + return ffebld_constant_logical6 (c) == 0; +#endif + +#if FFETARGET_okLOGICAL7 + case FFEBLD_constLOGICAL7: + return ffebld_constant_logical7 (c) == 0; +#endif + +#if FFETARGET_okLOGICAL8 + case FFEBLD_constLOGICAL8: + return ffebld_constant_logical8 (c) == 0; +#endif + +#if FFETARGET_okREAL1 + case FFEBLD_constREAL1: + return ffetarget_iszero_real1 (ffebld_constant_real1 (c)); +#endif + +#if FFETARGET_okREAL2 + case FFEBLD_constREAL2: + return ffetarget_iszero_real2 (ffebld_constant_real2 (c)); +#endif + +#if FFETARGET_okREAL3 + case FFEBLD_constREAL3: + return ffetarget_iszero_real3 (ffebld_constant_real3 (c)); +#endif + +#if FFETARGET_okREAL4 + case FFEBLD_constREAL4: + return ffetarget_iszero_real4 (ffebld_constant_real4 (c)); +#endif + +#if FFETARGET_okREAL5 + case FFEBLD_constREAL5: + return ffetarget_iszero_real5 (ffebld_constant_real5 (c)); +#endif + +#if FFETARGET_okREAL6 + case FFEBLD_constREAL6: + return ffetarget_iszero_real6 (ffebld_constant_real6 (c)); +#endif + +#if FFETARGET_okREAL7 + case FFEBLD_constREAL7: + return ffetarget_iszero_real7 (ffebld_constant_real7 (c)); +#endif + +#if FFETARGET_okREAL8 + case FFEBLD_constREAL8: + return ffetarget_iszero_real8 (ffebld_constant_real8 (c)); +#endif + +#if FFETARGET_okCOMPLEX1 + case FFEBLD_constCOMPLEX1: + return ffetarget_iszero_real1 (ffebld_constant_complex1 (c).real) + && ffetarget_iszero_real1 (ffebld_constant_complex1 (c).imaginary); +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEBLD_constCOMPLEX2: + return ffetarget_iszero_real2 (ffebld_constant_complex2 (c).real) + && ffetarget_iszero_real2 (ffebld_constant_complex2 (c).imaginary); +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEBLD_constCOMPLEX3: + return ffetarget_iszero_real3 (ffebld_constant_complex3 (c).real) + && ffetarget_iszero_real3 (ffebld_constant_complex3 (c).imaginary); +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEBLD_constCOMPLEX4: + return ffetarget_iszero_real4 (ffebld_constant_complex4 (c).real) + && ffetarget_iszero_real4 (ffebld_constant_complex4 (c).imaginary); +#endif + +#if FFETARGET_okCOMPLEX5 + case FFEBLD_constCOMPLEX5: + return ffetarget_iszero_real5 (ffebld_constant_complex5 (c).real) + && ffetarget_iszero_real5 (ffebld_constant_complex5 (c).imaginary); +#endif + +#if FFETARGET_okCOMPLEX6 + case FFEBLD_constCOMPLEX6: + return ffetarget_iszero_real6 (ffebld_constant_complex6 (c).real) + && ffetarget_iszero_real6 (ffebld_constant_complex6 (c).imaginary); +#endif + +#if FFETARGET_okCOMPLEX7 + case FFEBLD_constCOMPLEX7: + return ffetarget_iszero_real7 (ffebld_constant_complex7 (c).real) + && ffetarget_iszero_real7 (ffebld_constant_complex7 (c).imaginary); +#endif + +#if FFETARGET_okCOMPLEX8 + case FFEBLD_constCOMPLEX8: + return ffetarget_iszero_real8 (ffebld_constant_complex8 (c).real) + && ffetarget_iszero_real8 (ffebld_constant_complex8 (c).imaginary); +#endif + +#if FFETARGET_okCHARACTER1 + case FFEBLD_constCHARACTER1: + return ffetarget_iszero_character1 (ffebld_constant_character1 (c)); +#endif + +#if FFETARGET_okCHARACTER2 || FFETARGET_okCHARACTER3 /* ... */ +#error "no support for these!!" +#endif + + case FFEBLD_constHOLLERITH: + return ffetarget_iszero_hollerith (ffebld_constant_hollerith (c)); + + case FFEBLD_constBINARY_MIL: + case FFEBLD_constBINARY_VXT: + case FFEBLD_constOCTAL_MIL: + case FFEBLD_constOCTAL_VXT: + case FFEBLD_constHEX_X_MIL: + case FFEBLD_constHEX_X_VXT: + case FFEBLD_constHEX_Z_MIL: + case FFEBLD_constHEX_Z_VXT: + return ffetarget_iszero_typeless (ffebld_constant_typeless (c)); + + default: + return FALSE; + } +} + +/* ffebld_constant_new_character1 -- Return character1 constant object from token + + See prototype. */ + +#if FFETARGET_okCHARACTER1 +ffebldConstant +ffebld_constant_new_character1 (ffelexToken t) +{ + ffetargetCharacter1 val; + + ffetarget_character1 (&val, t, ffebld_constant_pool()); + return ffebld_constant_new_character1_val (val); +} + +#endif +/* ffebld_constant_new_character1_val -- Return an character1 constant object + + See prototype. */ + +#if FFETARGET_okCHARACTER1 +ffebldConstant +ffebld_constant_new_character1_val (ffetargetCharacter1 val) +{ + ffebldConstant c; + ffebldConstant nc; + int cmp; + + ffetarget_verify_character1 (ffebld_constant_pool(), val); + + for (c = (ffebldConstant) &ffebld_constant_character1_; + c->next != NULL; + c = c->next) + { + malloc_verify_kp (ffebld_constant_pool(), + c->next, + sizeof (*(c->next))); + ffetarget_verify_character1 (ffebld_constant_pool(), + ffebld_constant_character1 (c->next)); + cmp = ffetarget_cmp_character1 (val, + ffebld_constant_character1 (c->next)); + if (cmp == 0) + return c->next; + if (cmp > 0) + break; + } + + nc = malloc_new_kp (ffebld_constant_pool(), + "FFEBLD_constCHARACTER1", + sizeof (*nc)); + nc->next = c->next; + nc->consttype = FFEBLD_constCHARACTER1; + nc->u.character1 = val; +#ifdef FFECOM_constantHOOK + nc->hook = FFECOM_constantNULL; +#endif + c->next = nc; + + return nc; +} + +#endif +/* ffebld_constant_new_complex1 -- Return complex1 constant object from token + + See prototype. */ + +#if FFETARGET_okCOMPLEX1 +ffebldConstant +ffebld_constant_new_complex1 (ffebldConstant real, + ffebldConstant imaginary) +{ + ffetargetComplex1 val; + + val.real = ffebld_constant_real1 (real); + val.imaginary = ffebld_constant_real1 (imaginary); + return ffebld_constant_new_complex1_val (val); +} + +#endif +/* ffebld_constant_new_complex1_val -- Return a complex1 constant object + + See prototype. */ + +#if FFETARGET_okCOMPLEX1 +ffebldConstant +ffebld_constant_new_complex1_val (ffetargetComplex1 val) +{ + ffebldConstant c; + ffebldConstant nc; + int cmp; + + for (c = (ffebldConstant) &ffebld_constant_complex1_; + c->next != NULL; + c = c->next) + { + cmp = ffetarget_cmp_real1 (val.real, ffebld_constant_complex1 (c->next).real); + if (cmp == 0) + cmp = ffetarget_cmp_real1 (val.imaginary, + ffebld_constant_complex1 (c->next).imaginary); + if (cmp == 0) + return c->next; + if (cmp > 0) + break; + } + + nc = malloc_new_kp (ffebld_constant_pool(), + "FFEBLD_constCOMPLEX1", + sizeof (*nc)); + nc->next = c->next; + nc->consttype = FFEBLD_constCOMPLEX1; + nc->u.complex1 = val; +#ifdef FFECOM_constantHOOK + nc->hook = FFECOM_constantNULL; +#endif + c->next = nc; + + return nc; +} + +#endif +/* ffebld_constant_new_complex2 -- Return complex2 constant object from token + + See prototype. */ + +#if FFETARGET_okCOMPLEX2 +ffebldConstant +ffebld_constant_new_complex2 (ffebldConstant real, + ffebldConstant imaginary) +{ + ffetargetComplex2 val; + + val.real = ffebld_constant_real2 (real); + val.imaginary = ffebld_constant_real2 (imaginary); + return ffebld_constant_new_complex2_val (val); +} + +#endif +/* ffebld_constant_new_complex2_val -- Return a complex2 constant object + + See prototype. */ + +#if FFETARGET_okCOMPLEX2 +ffebldConstant +ffebld_constant_new_complex2_val (ffetargetComplex2 val) +{ + ffebldConstant c; + ffebldConstant nc; + int cmp; + + for (c = (ffebldConstant) &ffebld_constant_complex2_; + c->next != NULL; + c = c->next) + { + cmp = ffetarget_cmp_real2 (val.real, ffebld_constant_complex2 (c->next).real); + if (cmp == 0) + cmp = ffetarget_cmp_real2 (val.imaginary, + ffebld_constant_complex2 (c->next).imaginary); + if (cmp == 0) + return c->next; + if (cmp > 0) + break; + } + + nc = malloc_new_kp (ffebld_constant_pool(), + "FFEBLD_constCOMPLEX2", + sizeof (*nc)); + nc->next = c->next; + nc->consttype = FFEBLD_constCOMPLEX2; + nc->u.complex2 = val; +#ifdef FFECOM_constantHOOK + nc->hook = FFECOM_constantNULL; +#endif + c->next = nc; + + return nc; +} + +#endif +/* ffebld_constant_new_hollerith -- Return hollerith constant object from token + + See prototype. */ + +ffebldConstant +ffebld_constant_new_hollerith (ffelexToken t) +{ + ffetargetHollerith val; + + ffetarget_hollerith (&val, t, ffebld_constant_pool()); + return ffebld_constant_new_hollerith_val (val); +} + +/* ffebld_constant_new_hollerith_val -- Return an hollerith constant object + + See prototype. */ + +ffebldConstant +ffebld_constant_new_hollerith_val (ffetargetHollerith val) +{ + ffebldConstant c; + ffebldConstant nc; + int cmp; + + for (c = (ffebldConstant) &ffebld_constant_hollerith_; + c->next != NULL; + c = c->next) + { + cmp = ffetarget_cmp_hollerith (val, ffebld_constant_hollerith (c->next)); + if (cmp == 0) + return c->next; + if (cmp > 0) + break; + } + + nc = malloc_new_kp (ffebld_constant_pool(), + "FFEBLD_constHOLLERITH", + sizeof (*nc)); + nc->next = c->next; + nc->consttype = FFEBLD_constHOLLERITH; + nc->u.hollerith = val; +#ifdef FFECOM_constantHOOK + nc->hook = FFECOM_constantNULL; +#endif + c->next = nc; + + return nc; +} + +/* ffebld_constant_new_integer1 -- Return integer1 constant object from token + + See prototype. + + Parses the token as a decimal integer constant, thus it must be an + FFELEX_typeNUMBER. */ + +#if FFETARGET_okINTEGER1 +ffebldConstant +ffebld_constant_new_integer1 (ffelexToken t) +{ + ffetargetInteger1 val; + + assert (ffelex_token_type (t) == FFELEX_typeNUMBER); + + ffetarget_integer1 (&val, t); + return ffebld_constant_new_integer1_val (val); +} + +#endif +/* ffebld_constant_new_integer1_val -- Return an integer1 constant object + + See prototype. */ + +#if FFETARGET_okINTEGER1 +ffebldConstant +ffebld_constant_new_integer1_val (ffetargetInteger1 val) +{ + ffebldConstant c; + ffebldConstant nc; + int cmp; + + for (c = (ffebldConstant) &ffebld_constant_integer1_; + c->next != NULL; + c = c->next) + { + cmp = ffetarget_cmp_integer1 (val, ffebld_constant_integer1 (c->next)); + if (cmp == 0) + return c->next; + if (cmp > 0) + break; + } + + nc = malloc_new_kp (ffebld_constant_pool(), + "FFEBLD_constINTEGER1", + sizeof (*nc)); + nc->next = c->next; + nc->consttype = FFEBLD_constINTEGER1; + nc->u.integer1 = val; +#ifdef FFECOM_constantHOOK + nc->hook = FFECOM_constantNULL; +#endif + c->next = nc; + + return nc; +} + +#endif +/* ffebld_constant_new_integer2_val -- Return an integer2 constant object + + See prototype. */ + +#if FFETARGET_okINTEGER2 +ffebldConstant +ffebld_constant_new_integer2_val (ffetargetInteger2 val) +{ + ffebldConstant c; + ffebldConstant nc; + int cmp; + + for (c = (ffebldConstant) &ffebld_constant_integer2_; + c->next != NULL; + c = c->next) + { + cmp = ffetarget_cmp_integer2 (val, ffebld_constant_integer2 (c->next)); + if (cmp == 0) + return c->next; + if (cmp > 0) + break; + } + + nc = malloc_new_kp (ffebld_constant_pool(), + "FFEBLD_constINTEGER2", + sizeof (*nc)); + nc->next = c->next; + nc->consttype = FFEBLD_constINTEGER2; + nc->u.integer2 = val; +#ifdef FFECOM_constantHOOK + nc->hook = FFECOM_constantNULL; +#endif + c->next = nc; + + return nc; +} + +#endif +/* ffebld_constant_new_integer3_val -- Return an integer3 constant object + + See prototype. */ + +#if FFETARGET_okINTEGER3 +ffebldConstant +ffebld_constant_new_integer3_val (ffetargetInteger3 val) +{ + ffebldConstant c; + ffebldConstant nc; + int cmp; + + for (c = (ffebldConstant) &ffebld_constant_integer3_; + c->next != NULL; + c = c->next) + { + cmp = ffetarget_cmp_integer3 (val, ffebld_constant_integer3 (c->next)); + if (cmp == 0) + return c->next; + if (cmp > 0) + break; + } + + nc = malloc_new_kp (ffebld_constant_pool(), + "FFEBLD_constINTEGER3", + sizeof (*nc)); + nc->next = c->next; + nc->consttype = FFEBLD_constINTEGER3; + nc->u.integer3 = val; +#ifdef FFECOM_constantHOOK + nc->hook = FFECOM_constantNULL; +#endif + c->next = nc; + + return nc; +} + +#endif +/* ffebld_constant_new_integer4_val -- Return an integer4 constant object + + See prototype. */ + +#if FFETARGET_okINTEGER4 +ffebldConstant +ffebld_constant_new_integer4_val (ffetargetInteger4 val) +{ + ffebldConstant c; + ffebldConstant nc; + int cmp; + + for (c = (ffebldConstant) &ffebld_constant_integer4_; + c->next != NULL; + c = c->next) + { + cmp = ffetarget_cmp_integer4 (val, ffebld_constant_integer4 (c->next)); + if (cmp == 0) + return c->next; + if (cmp > 0) + break; + } + + nc = malloc_new_kp (ffebld_constant_pool(), + "FFEBLD_constINTEGER4", + sizeof (*nc)); + nc->next = c->next; + nc->consttype = FFEBLD_constINTEGER4; + nc->u.integer4 = val; +#ifdef FFECOM_constantHOOK + nc->hook = FFECOM_constantNULL; +#endif + c->next = nc; + + return nc; +} + +#endif +/* ffebld_constant_new_integerbinary -- Return binary constant object from token + + See prototype. + + Parses the token as a binary integer constant, thus it must be an + FFELEX_typeNUMBER. */ + +ffebldConstant +ffebld_constant_new_integerbinary (ffelexToken t) +{ + ffetargetIntegerDefault val; + + assert ((ffelex_token_type (t) == FFELEX_typeNAME) + || (ffelex_token_type (t) == FFELEX_typeNUMBER)); + + ffetarget_integerbinary (&val, t); + return ffebld_constant_new_integerdefault_val (val); +} + +/* ffebld_constant_new_integerhex -- Return hex constant object from token + + See prototype. + + Parses the token as a hex integer constant, thus it must be an + FFELEX_typeNUMBER. */ + +ffebldConstant +ffebld_constant_new_integerhex (ffelexToken t) +{ + ffetargetIntegerDefault val; + + assert ((ffelex_token_type (t) == FFELEX_typeNAME) + || (ffelex_token_type (t) == FFELEX_typeNUMBER)); + + ffetarget_integerhex (&val, t); + return ffebld_constant_new_integerdefault_val (val); +} + +/* ffebld_constant_new_integeroctal -- Return octal constant object from token + + See prototype. + + Parses the token as a octal integer constant, thus it must be an + FFELEX_typeNUMBER. */ + +ffebldConstant +ffebld_constant_new_integeroctal (ffelexToken t) +{ + ffetargetIntegerDefault val; + + assert ((ffelex_token_type (t) == FFELEX_typeNAME) + || (ffelex_token_type (t) == FFELEX_typeNUMBER)); + + ffetarget_integeroctal (&val, t); + return ffebld_constant_new_integerdefault_val (val); +} + +/* ffebld_constant_new_logical1 -- Return logical1 constant object from token + + See prototype. + + Parses the token as a decimal logical constant, thus it must be an + FFELEX_typeNUMBER. */ + +#if FFETARGET_okLOGICAL1 +ffebldConstant +ffebld_constant_new_logical1 (bool truth) +{ + ffetargetLogical1 val; + + ffetarget_logical1 (&val, truth); + return ffebld_constant_new_logical1_val (val); +} + +#endif +/* ffebld_constant_new_logical1_val -- Return a logical1 constant object + + See prototype. */ + +#if FFETARGET_okLOGICAL1 +ffebldConstant +ffebld_constant_new_logical1_val (ffetargetLogical1 val) +{ + ffebldConstant c; + ffebldConstant nc; + int cmp; + + for (c = (ffebldConstant) &ffebld_constant_logical1_; + c->next != NULL; + c = c->next) + { + cmp = ffetarget_cmp_logical1 (val, ffebld_constant_logical1 (c->next)); + if (cmp == 0) + return c->next; + if (cmp > 0) + break; + } + + nc = malloc_new_kp (ffebld_constant_pool(), + "FFEBLD_constLOGICAL1", + sizeof (*nc)); + nc->next = c->next; + nc->consttype = FFEBLD_constLOGICAL1; + nc->u.logical1 = val; +#ifdef FFECOM_constantHOOK + nc->hook = FFECOM_constantNULL; +#endif + c->next = nc; + + return nc; +} + +#endif +/* ffebld_constant_new_logical2_val -- Return a logical2 constant object + + See prototype. */ + +#if FFETARGET_okLOGICAL2 +ffebldConstant +ffebld_constant_new_logical2_val (ffetargetLogical2 val) +{ + ffebldConstant c; + ffebldConstant nc; + int cmp; + + for (c = (ffebldConstant) &ffebld_constant_logical2_; + c->next != NULL; + c = c->next) + { + cmp = ffetarget_cmp_logical2 (val, ffebld_constant_logical2 (c->next)); + if (cmp == 0) + return c->next; + if (cmp > 0) + break; + } + + nc = malloc_new_kp (ffebld_constant_pool(), + "FFEBLD_constLOGICAL2", + sizeof (*nc)); + nc->next = c->next; + nc->consttype = FFEBLD_constLOGICAL2; + nc->u.logical2 = val; +#ifdef FFECOM_constantHOOK + nc->hook = FFECOM_constantNULL; +#endif + c->next = nc; + + return nc; +} + +#endif +/* ffebld_constant_new_logical3_val -- Return a logical3 constant object + + See prototype. */ + +#if FFETARGET_okLOGICAL3 +ffebldConstant +ffebld_constant_new_logical3_val (ffetargetLogical3 val) +{ + ffebldConstant c; + ffebldConstant nc; + int cmp; + + for (c = (ffebldConstant) &ffebld_constant_logical3_; + c->next != NULL; + c = c->next) + { + cmp = ffetarget_cmp_logical3 (val, ffebld_constant_logical3 (c->next)); + if (cmp == 0) + return c->next; + if (cmp > 0) + break; + } + + nc = malloc_new_kp (ffebld_constant_pool(), + "FFEBLD_constLOGICAL3", + sizeof (*nc)); + nc->next = c->next; + nc->consttype = FFEBLD_constLOGICAL3; + nc->u.logical3 = val; +#ifdef FFECOM_constantHOOK + nc->hook = FFECOM_constantNULL; +#endif + c->next = nc; + + return nc; +} + +#endif +/* ffebld_constant_new_logical4_val -- Return a logical4 constant object + + See prototype. */ + +#if FFETARGET_okLOGICAL4 +ffebldConstant +ffebld_constant_new_logical4_val (ffetargetLogical4 val) +{ + ffebldConstant c; + ffebldConstant nc; + int cmp; + + for (c = (ffebldConstant) &ffebld_constant_logical4_; + c->next != NULL; + c = c->next) + { + cmp = ffetarget_cmp_logical4 (val, ffebld_constant_logical4 (c->next)); + if (cmp == 0) + return c->next; + if (cmp > 0) + break; + } + + nc = malloc_new_kp (ffebld_constant_pool(), + "FFEBLD_constLOGICAL4", + sizeof (*nc)); + nc->next = c->next; + nc->consttype = FFEBLD_constLOGICAL4; + nc->u.logical4 = val; +#ifdef FFECOM_constantHOOK + nc->hook = FFECOM_constantNULL; +#endif + c->next = nc; + + return nc; +} + +#endif +/* ffebld_constant_new_real1 -- Return real1 constant object from token + + See prototype. */ + +#if FFETARGET_okREAL1 +ffebldConstant +ffebld_constant_new_real1 (ffelexToken integer, ffelexToken decimal, + ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign, + ffelexToken exponent_digits) +{ + ffetargetReal1 val; + + ffetarget_real1 (&val, + integer, decimal, fraction, exponent, exponent_sign, exponent_digits); + return ffebld_constant_new_real1_val (val); +} + +#endif +/* ffebld_constant_new_real1_val -- Return an real1 constant object + + See prototype. */ + +#if FFETARGET_okREAL1 +ffebldConstant +ffebld_constant_new_real1_val (ffetargetReal1 val) +{ + ffebldConstant c; + ffebldConstant nc; + int cmp; + + for (c = (ffebldConstant) &ffebld_constant_real1_; + c->next != NULL; + c = c->next) + { + cmp = ffetarget_cmp_real1 (val, ffebld_constant_real1 (c->next)); + if (cmp == 0) + return c->next; + if (cmp > 0) + break; + } + + nc = malloc_new_kp (ffebld_constant_pool(), + "FFEBLD_constREAL1", + sizeof (*nc)); + nc->next = c->next; + nc->consttype = FFEBLD_constREAL1; + nc->u.real1 = val; +#ifdef FFECOM_constantHOOK + nc->hook = FFECOM_constantNULL; +#endif + c->next = nc; + + return nc; +} + +#endif +/* ffebld_constant_new_real2 -- Return real2 constant object from token + + See prototype. */ + +#if FFETARGET_okREAL2 +ffebldConstant +ffebld_constant_new_real2 (ffelexToken integer, ffelexToken decimal, + ffelexToken fraction, ffelexToken exponent, ffelexToken exponent_sign, + ffelexToken exponent_digits) +{ + ffetargetReal2 val; + + ffetarget_real2 (&val, + integer, decimal, fraction, exponent, exponent_sign, exponent_digits); + return ffebld_constant_new_real2_val (val); +} + +#endif +/* ffebld_constant_new_real2_val -- Return an real2 constant object + + See prototype. */ + +#if FFETARGET_okREAL2 +ffebldConstant +ffebld_constant_new_real2_val (ffetargetReal2 val) +{ + ffebldConstant c; + ffebldConstant nc; + int cmp; + + for (c = (ffebldConstant) &ffebld_constant_real2_; + c->next != NULL; + c = c->next) + { + cmp = ffetarget_cmp_real2 (val, ffebld_constant_real2 (c->next)); + if (cmp == 0) + return c->next; + if (cmp > 0) + break; + } + + nc = malloc_new_kp (ffebld_constant_pool(), + "FFEBLD_constREAL2", + sizeof (*nc)); + nc->next = c->next; + nc->consttype = FFEBLD_constREAL2; + nc->u.real2 = val; +#ifdef FFECOM_constantHOOK + nc->hook = FFECOM_constantNULL; +#endif + c->next = nc; + + return nc; +} + +#endif +/* ffebld_constant_new_typeless_bm -- Return typeless constant object from token + + See prototype. + + Parses the token as a decimal integer constant, thus it must be an + FFELEX_typeNUMBER. */ + +ffebldConstant +ffebld_constant_new_typeless_bm (ffelexToken t) +{ + ffetargetTypeless val; + + ffetarget_binarymil (&val, t); + return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_MIL, val); +} + +/* ffebld_constant_new_typeless_bv -- Return typeless constant object from token + + See prototype. + + Parses the token as a decimal integer constant, thus it must be an + FFELEX_typeNUMBER. */ + +ffebldConstant +ffebld_constant_new_typeless_bv (ffelexToken t) +{ + ffetargetTypeless val; + + ffetarget_binaryvxt (&val, t); + return ffebld_constant_new_typeless_val (FFEBLD_constBINARY_VXT, val); +} + +/* ffebld_constant_new_typeless_hxm -- Return typeless constant object from token + + See prototype. + + Parses the token as a decimal integer constant, thus it must be an + FFELEX_typeNUMBER. */ + +ffebldConstant +ffebld_constant_new_typeless_hxm (ffelexToken t) +{ + ffetargetTypeless val; + + ffetarget_hexxmil (&val, t); + return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_MIL, val); +} + +/* ffebld_constant_new_typeless_hxv -- Return typeless constant object from token + + See prototype. + + Parses the token as a decimal integer constant, thus it must be an + FFELEX_typeNUMBER. */ + +ffebldConstant +ffebld_constant_new_typeless_hxv (ffelexToken t) +{ + ffetargetTypeless val; + + ffetarget_hexxvxt (&val, t); + return ffebld_constant_new_typeless_val (FFEBLD_constHEX_X_VXT, val); +} + +/* ffebld_constant_new_typeless_hzm -- Return typeless constant object from token + + See prototype. + + Parses the token as a decimal integer constant, thus it must be an + FFELEX_typeNUMBER. */ + +ffebldConstant +ffebld_constant_new_typeless_hzm (ffelexToken t) +{ + ffetargetTypeless val; + + ffetarget_hexzmil (&val, t); + return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_MIL, val); +} + +/* ffebld_constant_new_typeless_hzv -- Return typeless constant object from token + + See prototype. + + Parses the token as a decimal integer constant, thus it must be an + FFELEX_typeNUMBER. */ + +ffebldConstant +ffebld_constant_new_typeless_hzv (ffelexToken t) +{ + ffetargetTypeless val; + + ffetarget_hexzvxt (&val, t); + return ffebld_constant_new_typeless_val (FFEBLD_constHEX_Z_VXT, val); +} + +/* ffebld_constant_new_typeless_om -- Return typeless constant object from token + + See prototype. + + Parses the token as a decimal integer constant, thus it must be an + FFELEX_typeNUMBER. */ + +ffebldConstant +ffebld_constant_new_typeless_om (ffelexToken t) +{ + ffetargetTypeless val; + + ffetarget_octalmil (&val, t); + return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_MIL, val); +} + +/* ffebld_constant_new_typeless_ov -- Return typeless constant object from token + + See prototype. + + Parses the token as a decimal integer constant, thus it must be an + FFELEX_typeNUMBER. */ + +ffebldConstant +ffebld_constant_new_typeless_ov (ffelexToken t) +{ + ffetargetTypeless val; + + ffetarget_octalvxt (&val, t); + return ffebld_constant_new_typeless_val (FFEBLD_constOCTAL_VXT, val); +} + +/* ffebld_constant_new_typeless_val -- Return a typeless constant object + + See prototype. */ + +ffebldConstant +ffebld_constant_new_typeless_val (ffebldConst type, ffetargetTypeless val) +{ + ffebldConstant c; + ffebldConstant nc; + int cmp; + + for (c = (ffebldConstant) &ffebld_constant_typeless_[type + - FFEBLD_constTYPELESS_FIRST]; + c->next != NULL; + c = c->next) + { + cmp = ffetarget_cmp_typeless (val, ffebld_constant_typeless (c->next)); + if (cmp == 0) + return c->next; + if (cmp > 0) + break; + } + + nc = malloc_new_kp (ffebld_constant_pool(), + "FFEBLD_constTYPELESS", + sizeof (*nc)); + nc->next = c->next; + nc->consttype = type; + nc->u.typeless = val; +#ifdef FFECOM_constantHOOK + nc->hook = FFECOM_constantNULL; +#endif + c->next = nc; + + 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); + + 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. */ + +void +ffebld_constantarray_dump (ffebldConstantArray array, ffeinfoBasictype bt, + ffeinfoKindtype kt, ffetargetOffset size, ffebit bits) +{ + ffetargetOffset i; + ffebitCount j; + + ffebld_dump_prefix (dmpout, bt, kt); + + fprintf (dmpout, "\\("); + + 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, "\\)"); + +} + +/* 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) + { + case FFEINFO_basictypeINTEGER: + switch (kt) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + u.integer1 = *(array.integer1 + offset); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + u.integer2 = *(array.integer2 + offset); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + u.integer3 = *(array.integer3 + offset); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + u.integer4 = *(array.integer4 + offset); + break; +#endif + +#if FFETARGET_okINTEGER5 + case FFEINFO_kindtypeINTEGER5: + u.integer5 = *(array.integer5 + offset); + break; +#endif + +#if FFETARGET_okINTEGER6 + case FFEINFO_kindtypeINTEGER6: + u.integer6 = *(array.integer6 + offset); + break; +#endif + +#if FFETARGET_okINTEGER7 + case FFEINFO_kindtypeINTEGER7: + u.integer7 = *(array.integer7 + offset); + break; +#endif + +#if FFETARGET_okINTEGER8 + case FFEINFO_kindtypeINTEGER8: + u.integer8 = *(array.integer8 + offset); + break; +#endif + + default: + assert ("bad INTEGER kindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + switch (kt) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + u.logical1 = *(array.logical1 + offset); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + u.logical2 = *(array.logical2 + offset); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + u.logical3 = *(array.logical3 + offset); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + u.logical4 = *(array.logical4 + offset); + break; +#endif + +#if FFETARGET_okLOGICAL5 + case FFEINFO_kindtypeLOGICAL5: + u.logical5 = *(array.logical5 + offset); + break; +#endif + +#if FFETARGET_okLOGICAL6 + case FFEINFO_kindtypeLOGICAL6: + u.logical6 = *(array.logical6 + offset); + break; +#endif + +#if FFETARGET_okLOGICAL7 + case FFEINFO_kindtypeLOGICAL7: + u.logical7 = *(array.logical7 + offset); + break; +#endif + +#if FFETARGET_okLOGICAL8 + case FFEINFO_kindtypeLOGICAL8: + u.logical8 = *(array.logical8 + offset); + break; +#endif + + default: + assert ("bad LOGICAL kindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (kt) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + u.real1 = *(array.real1 + offset); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + u.real2 = *(array.real2 + offset); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + u.real3 = *(array.real3 + offset); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + u.real4 = *(array.real4 + offset); + break; +#endif + +#if FFETARGET_okREAL5 + case FFEINFO_kindtypeREAL5: + u.real5 = *(array.real5 + offset); + break; +#endif + +#if FFETARGET_okREAL6 + case FFEINFO_kindtypeREAL6: + u.real6 = *(array.real6 + offset); + break; +#endif + +#if FFETARGET_okREAL7 + case FFEINFO_kindtypeREAL7: + u.real7 = *(array.real7 + offset); + break; +#endif + +#if FFETARGET_okREAL8 + case FFEINFO_kindtypeREAL8: + u.real8 = *(array.real8 + offset); + break; +#endif + + default: + assert ("bad REAL kindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (kt) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + u.complex1 = *(array.complex1 + offset); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + u.complex2 = *(array.complex2 + offset); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + u.complex3 = *(array.complex3 + offset); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + u.complex4 = *(array.complex4 + offset); + break; +#endif + +#if FFETARGET_okCOMPLEX5 + case FFEINFO_kindtypeREAL5: + u.complex5 = *(array.complex5 + offset); + break; +#endif + +#if FFETARGET_okCOMPLEX6 + case FFEINFO_kindtypeREAL6: + u.complex6 = *(array.complex6 + offset); + break; +#endif + +#if FFETARGET_okCOMPLEX7 + case FFEINFO_kindtypeREAL7: + u.complex7 = *(array.complex7 + offset); + break; +#endif + +#if FFETARGET_okCOMPLEX8 + case FFEINFO_kindtypeREAL8: + u.complex8 = *(array.complex8 + offset); + break; +#endif + + default: + assert ("bad COMPLEX kindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + switch (kt) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeCHARACTER1: + u.character1.length = 1; + u.character1.text = array.character1 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER2 + case FFEINFO_kindtypeCHARACTER2: + u.character2.length = 1; + u.character2.text = array.character2 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER3 + case FFEINFO_kindtypeCHARACTER3: + u.character3.length = 1; + u.character3.text = array.character3 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER4 + case FFEINFO_kindtypeCHARACTER4: + u.character4.length = 1; + u.character4.text = array.character4 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER5 + case FFEINFO_kindtypeCHARACTER5: + u.character5.length = 1; + u.character5.text = array.character5 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER6 + case FFEINFO_kindtypeCHARACTER6: + u.character6.length = 1; + u.character6.text = array.character6 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER7 + case FFEINFO_kindtypeCHARACTER7: + u.character7.length = 1; + u.character7.text = array.character7 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER8 + case FFEINFO_kindtypeCHARACTER8: + u.character8.length = 1; + u.character8.text = array.character8 + offset; + break; +#endif + + default: + assert ("bad CHARACTER kindtype" == NULL); + break; + } + break; + + default: + assert ("bad basictype" == NULL); + break; + } + + return u; +} + +/* ffebld_constantarray_new -- Make an array of constants + + See prototype. */ + +ffebldConstantArray +ffebld_constantarray_new (ffeinfoBasictype bt, + ffeinfoKindtype kt, ffetargetOffset size) +{ + ffebldConstantArray ptr; + + switch (bt) + { + case FFEINFO_basictypeINTEGER: + switch (kt) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + ptr.integer1 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetInteger1), + 0); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + ptr.integer2 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetInteger2), + 0); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + ptr.integer3 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetInteger3), + 0); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + ptr.integer4 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetInteger4), + 0); + break; +#endif + +#if FFETARGET_okINTEGER5 + case FFEINFO_kindtypeINTEGER5: + ptr.integer5 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetInteger5), + 0); + break; +#endif + +#if FFETARGET_okINTEGER6 + case FFEINFO_kindtypeINTEGER6: + ptr.integer6 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetInteger6), + 0); + break; +#endif + +#if FFETARGET_okINTEGER7 + case FFEINFO_kindtypeINTEGER7: + ptr.integer7 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetInteger7), + 0); + break; +#endif + +#if FFETARGET_okINTEGER8 + case FFEINFO_kindtypeINTEGER8: + ptr.integer8 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetInteger8), + 0); + break; +#endif + + default: + assert ("bad INTEGER kindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + switch (kt) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + ptr.logical1 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetLogical1), + 0); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + ptr.logical2 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetLogical2), + 0); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + ptr.logical3 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetLogical3), + 0); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + ptr.logical4 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetLogical4), + 0); + break; +#endif + +#if FFETARGET_okLOGICAL5 + case FFEINFO_kindtypeLOGICAL5: + ptr.logical5 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetLogical5), + 0); + break; +#endif + +#if FFETARGET_okLOGICAL6 + case FFEINFO_kindtypeLOGICAL6: + ptr.logical6 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetLogical6), + 0); + break; +#endif + +#if FFETARGET_okLOGICAL7 + case FFEINFO_kindtypeLOGICAL7: + ptr.logical7 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetLogical7), + 0); + break; +#endif + +#if FFETARGET_okLOGICAL8 + case FFEINFO_kindtypeLOGICAL8: + ptr.logical8 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetLogical8), + 0); + break; +#endif + + default: + assert ("bad LOGICAL kindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (kt) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + ptr.real1 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetReal1), + 0); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + ptr.real2 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetReal2), + 0); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + ptr.real3 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetReal3), + 0); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + ptr.real4 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetReal4), + 0); + break; +#endif + +#if FFETARGET_okREAL5 + case FFEINFO_kindtypeREAL5: + ptr.real5 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetReal5), + 0); + break; +#endif + +#if FFETARGET_okREAL6 + case FFEINFO_kindtypeREAL6: + ptr.real6 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetReal6), + 0); + break; +#endif + +#if FFETARGET_okREAL7 + case FFEINFO_kindtypeREAL7: + ptr.real7 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetReal7), + 0); + break; +#endif + +#if FFETARGET_okREAL8 + case FFEINFO_kindtypeREAL8: + ptr.real8 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetReal8), + 0); + break; +#endif + + default: + assert ("bad REAL kindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (kt) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + ptr.complex1 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetComplex1), + 0); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + ptr.complex2 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetComplex2), + 0); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + ptr.complex3 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetComplex3), + 0); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + ptr.complex4 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetComplex4), + 0); + break; +#endif + +#if FFETARGET_okCOMPLEX5 + case FFEINFO_kindtypeREAL5: + ptr.complex5 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetComplex5), + 0); + break; +#endif + +#if FFETARGET_okCOMPLEX6 + case FFEINFO_kindtypeREAL6: + ptr.complex6 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetComplex6), + 0); + break; +#endif + +#if FFETARGET_okCOMPLEX7 + case FFEINFO_kindtypeREAL7: + ptr.complex7 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetComplex7), + 0); + break; +#endif + +#if FFETARGET_okCOMPLEX8 + case FFEINFO_kindtypeREAL8: + ptr.complex8 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size *= sizeof (ffetargetComplex8), + 0); + break; +#endif + + default: + assert ("bad COMPLEX kindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + switch (kt) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeCHARACTER1: + ptr.character1 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size + *= sizeof (ffetargetCharacterUnit1), + 0); + break; +#endif + +#if FFETARGET_okCHARACTER2 + case FFEINFO_kindtypeCHARACTER2: + ptr.character2 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size + *= sizeof (ffetargetCharacterUnit2), + 0); + break; +#endif + +#if FFETARGET_okCHARACTER3 + case FFEINFO_kindtypeCHARACTER3: + ptr.character3 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size + *= sizeof (ffetargetCharacterUnit3), + 0); + break; +#endif + +#if FFETARGET_okCHARACTER4 + case FFEINFO_kindtypeCHARACTER4: + ptr.character4 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size + *= sizeof (ffetargetCharacterUnit4), + 0); + break; +#endif + +#if FFETARGET_okCHARACTER5 + case FFEINFO_kindtypeCHARACTER5: + ptr.character5 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size + *= sizeof (ffetargetCharacterUnit5), + 0); + break; +#endif + +#if FFETARGET_okCHARACTER6 + case FFEINFO_kindtypeCHARACTER6: + ptr.character6 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size + *= sizeof (ffetargetCharacterUnit6), + 0); + break; +#endif + +#if FFETARGET_okCHARACTER7 + case FFEINFO_kindtypeCHARACTER7: + ptr.character7 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size + *= sizeof (ffetargetCharacterUnit7), + 0); + break; +#endif + +#if FFETARGET_okCHARACTER8 + case FFEINFO_kindtypeCHARACTER8: + ptr.character8 = malloc_new_zkp (ffebld_constant_pool(), + "ffebldConstantArray", + size + *= sizeof (ffetargetCharacterUnit8), + 0); + break; +#endif + + default: + assert ("bad CHARACTER kindtype" == NULL); + break; + } + break; + + default: + assert ("bad basictype" == NULL); + break; + } + + return ptr; +} + +/* ffebld_constantarray_preparray -- Prepare for copy between arrays + + See prototype. + + Like _prepare, but the source is an array instead of a single-value + constant. */ + +void +ffebld_constantarray_preparray (void **aptr, void **cptr, size_t *size, + ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt, + ffetargetOffset offset, ffebldConstantArray source_array, + ffeinfoBasictype cbt, ffeinfoKindtype ckt) +{ + switch (abt) + { + case FFEINFO_basictypeINTEGER: + switch (akt) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + *aptr = array.integer1 + offset; + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + *aptr = array.integer2 + offset; + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + *aptr = array.integer3 + offset; + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + *aptr = array.integer4 + offset; + break; +#endif + +#if FFETARGET_okINTEGER5 + case FFEINFO_kindtypeINTEGER5: + *aptr = array.integer5 + offset; + break; +#endif + +#if FFETARGET_okINTEGER6 + case FFEINFO_kindtypeINTEGER6: + *aptr = array.integer6 + offset; + break; +#endif + +#if FFETARGET_okINTEGER7 + case FFEINFO_kindtypeINTEGER7: + *aptr = array.integer7 + offset; + break; +#endif + +#if FFETARGET_okINTEGER8 + case FFEINFO_kindtypeINTEGER8: + *aptr = array.integer8 + offset; + break; +#endif + + default: + assert ("bad INTEGER akindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + switch (akt) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + *aptr = array.logical1 + offset; + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + *aptr = array.logical2 + offset; + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + *aptr = array.logical3 + offset; + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + *aptr = array.logical4 + offset; + break; +#endif + +#if FFETARGET_okLOGICAL5 + case FFEINFO_kindtypeLOGICAL5: + *aptr = array.logical5 + offset; + break; +#endif + +#if FFETARGET_okLOGICAL6 + case FFEINFO_kindtypeLOGICAL6: + *aptr = array.logical6 + offset; + break; +#endif + +#if FFETARGET_okLOGICAL7 + case FFEINFO_kindtypeLOGICAL7: + *aptr = array.logical7 + offset; + break; +#endif + +#if FFETARGET_okLOGICAL8 + case FFEINFO_kindtypeLOGICAL8: + *aptr = array.logical8 + offset; + break; +#endif + + default: + assert ("bad LOGICAL akindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (akt) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + *aptr = array.real1 + offset; + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + *aptr = array.real2 + offset; + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + *aptr = array.real3 + offset; + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + *aptr = array.real4 + offset; + break; +#endif + +#if FFETARGET_okREAL5 + case FFEINFO_kindtypeREAL5: + *aptr = array.real5 + offset; + break; +#endif + +#if FFETARGET_okREAL6 + case FFEINFO_kindtypeREAL6: + *aptr = array.real6 + offset; + break; +#endif + +#if FFETARGET_okREAL7 + case FFEINFO_kindtypeREAL7: + *aptr = array.real7 + offset; + break; +#endif + +#if FFETARGET_okREAL8 + case FFEINFO_kindtypeREAL8: + *aptr = array.real8 + offset; + break; +#endif + + default: + assert ("bad REAL akindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (akt) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + *aptr = array.complex1 + offset; + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + *aptr = array.complex2 + offset; + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + *aptr = array.complex3 + offset; + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + *aptr = array.complex4 + offset; + break; +#endif + +#if FFETARGET_okCOMPLEX5 + case FFEINFO_kindtypeREAL5: + *aptr = array.complex5 + offset; + break; +#endif + +#if FFETARGET_okCOMPLEX6 + case FFEINFO_kindtypeREAL6: + *aptr = array.complex6 + offset; + break; +#endif + +#if FFETARGET_okCOMPLEX7 + case FFEINFO_kindtypeREAL7: + *aptr = array.complex7 + offset; + break; +#endif + +#if FFETARGET_okCOMPLEX8 + case FFEINFO_kindtypeREAL8: + *aptr = array.complex8 + offset; + break; +#endif + + default: + assert ("bad COMPLEX akindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + switch (akt) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeCHARACTER1: + *aptr = array.character1 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER2 + case FFEINFO_kindtypeCHARACTER2: + *aptr = array.character2 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER3 + case FFEINFO_kindtypeCHARACTER3: + *aptr = array.character3 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER4 + case FFEINFO_kindtypeCHARACTER4: + *aptr = array.character4 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER5 + case FFEINFO_kindtypeCHARACTER5: + *aptr = array.character5 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER6 + case FFEINFO_kindtypeCHARACTER6: + *aptr = array.character6 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER7 + case FFEINFO_kindtypeCHARACTER7: + *aptr = array.character7 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER8 + case FFEINFO_kindtypeCHARACTER8: + *aptr = array.character8 + offset; + break; +#endif + + default: + assert ("bad CHARACTER akindtype" == NULL); + break; + } + break; + + default: + assert ("bad abasictype" == NULL); + break; + } + + switch (cbt) + { + case FFEINFO_basictypeINTEGER: + switch (ckt) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + *cptr = source_array.integer1; + *size = sizeof (*source_array.integer1); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + *cptr = source_array.integer2; + *size = sizeof (*source_array.integer2); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + *cptr = source_array.integer3; + *size = sizeof (*source_array.integer3); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + *cptr = source_array.integer4; + *size = sizeof (*source_array.integer4); + break; +#endif + +#if FFETARGET_okINTEGER5 + case FFEINFO_kindtypeINTEGER5: + *cptr = source_array.integer5; + *size = sizeof (*source_array.integer5); + break; +#endif + +#if FFETARGET_okINTEGER6 + case FFEINFO_kindtypeINTEGER6: + *cptr = source_array.integer6; + *size = sizeof (*source_array.integer6); + break; +#endif + +#if FFETARGET_okINTEGER7 + case FFEINFO_kindtypeINTEGER7: + *cptr = source_array.integer7; + *size = sizeof (*source_array.integer7); + break; +#endif + +#if FFETARGET_okINTEGER8 + case FFEINFO_kindtypeINTEGER8: + *cptr = source_array.integer8; + *size = sizeof (*source_array.integer8); + break; +#endif + + default: + assert ("bad INTEGER ckindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + switch (ckt) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + *cptr = source_array.logical1; + *size = sizeof (*source_array.logical1); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + *cptr = source_array.logical2; + *size = sizeof (*source_array.logical2); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + *cptr = source_array.logical3; + *size = sizeof (*source_array.logical3); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + *cptr = source_array.logical4; + *size = sizeof (*source_array.logical4); + break; +#endif + +#if FFETARGET_okLOGICAL5 + case FFEINFO_kindtypeLOGICAL5: + *cptr = source_array.logical5; + *size = sizeof (*source_array.logical5); + break; +#endif + +#if FFETARGET_okLOGICAL6 + case FFEINFO_kindtypeLOGICAL6: + *cptr = source_array.logical6; + *size = sizeof (*source_array.logical6); + break; +#endif + +#if FFETARGET_okLOGICAL7 + case FFEINFO_kindtypeLOGICAL7: + *cptr = source_array.logical7; + *size = sizeof (*source_array.logical7); + break; +#endif + +#if FFETARGET_okLOGICAL8 + case FFEINFO_kindtypeLOGICAL8: + *cptr = source_array.logical8; + *size = sizeof (*source_array.logical8); + break; +#endif + + default: + assert ("bad LOGICAL ckindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ckt) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + *cptr = source_array.real1; + *size = sizeof (*source_array.real1); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + *cptr = source_array.real2; + *size = sizeof (*source_array.real2); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + *cptr = source_array.real3; + *size = sizeof (*source_array.real3); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + *cptr = source_array.real4; + *size = sizeof (*source_array.real4); + break; +#endif + +#if FFETARGET_okREAL5 + case FFEINFO_kindtypeREAL5: + *cptr = source_array.real5; + *size = sizeof (*source_array.real5); + break; +#endif + +#if FFETARGET_okREAL6 + case FFEINFO_kindtypeREAL6: + *cptr = source_array.real6; + *size = sizeof (*source_array.real6); + break; +#endif + +#if FFETARGET_okREAL7 + case FFEINFO_kindtypeREAL7: + *cptr = source_array.real7; + *size = sizeof (*source_array.real7); + break; +#endif + +#if FFETARGET_okREAL8 + case FFEINFO_kindtypeREAL8: + *cptr = source_array.real8; + *size = sizeof (*source_array.real8); + break; +#endif + + default: + assert ("bad REAL ckindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (ckt) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + *cptr = source_array.complex1; + *size = sizeof (*source_array.complex1); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + *cptr = source_array.complex2; + *size = sizeof (*source_array.complex2); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + *cptr = source_array.complex3; + *size = sizeof (*source_array.complex3); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + *cptr = source_array.complex4; + *size = sizeof (*source_array.complex4); + break; +#endif + +#if FFETARGET_okCOMPLEX5 + case FFEINFO_kindtypeREAL5: + *cptr = source_array.complex5; + *size = sizeof (*source_array.complex5); + break; +#endif + +#if FFETARGET_okCOMPLEX6 + case FFEINFO_kindtypeREAL6: + *cptr = source_array.complex6; + *size = sizeof (*source_array.complex6); + break; +#endif + +#if FFETARGET_okCOMPLEX7 + case FFEINFO_kindtypeREAL7: + *cptr = source_array.complex7; + *size = sizeof (*source_array.complex7); + break; +#endif + +#if FFETARGET_okCOMPLEX8 + case FFEINFO_kindtypeREAL8: + *cptr = source_array.complex8; + *size = sizeof (*source_array.complex8); + break; +#endif + + default: + assert ("bad COMPLEX ckindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + switch (ckt) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeCHARACTER1: + *cptr = source_array.character1; + *size = sizeof (*source_array.character1); + break; +#endif + +#if FFETARGET_okCHARACTER2 + case FFEINFO_kindtypeCHARACTER2: + *cptr = source_array.character2; + *size = sizeof (*source_array.character2); + break; +#endif + +#if FFETARGET_okCHARACTER3 + case FFEINFO_kindtypeCHARACTER3: + *cptr = source_array.character3; + *size = sizeof (*source_array.character3); + break; +#endif + +#if FFETARGET_okCHARACTER4 + case FFEINFO_kindtypeCHARACTER4: + *cptr = source_array.character4; + *size = sizeof (*source_array.character4); + break; +#endif + +#if FFETARGET_okCHARACTER5 + case FFEINFO_kindtypeCHARACTER5: + *cptr = source_array.character5; + *size = sizeof (*source_array.character5); + break; +#endif + +#if FFETARGET_okCHARACTER6 + case FFEINFO_kindtypeCHARACTER6: + *cptr = source_array.character6; + *size = sizeof (*source_array.character6); + break; +#endif + +#if FFETARGET_okCHARACTER7 + case FFEINFO_kindtypeCHARACTER7: + *cptr = source_array.character7; + *size = sizeof (*source_array.character7); + break; +#endif + +#if FFETARGET_okCHARACTER8 + case FFEINFO_kindtypeCHARACTER8: + *cptr = source_array.character8; + *size = sizeof (*source_array.character8); + break; +#endif + + default: + assert ("bad CHARACTER ckindtype" == NULL); + break; + } + break; + + default: + assert ("bad cbasictype" == NULL); + break; + } +} + +/* ffebld_constantarray_prepare -- Prepare for copy between value and array + + See prototype. + + Like _put, but just returns the pointers to the beginnings of the + array and the constant and returns the size (the amount of info to + copy). The idea is that the caller can use memcpy to accomplish the + same thing as _put (though slower), or the caller can use a different + function that swaps bytes, words, etc for a different target machine. + Also, the type of the array may be different from the type of the + constant; the array type is used to determine the meaning (scale) of + the offset field (to calculate the array pointer), the constant type is + used to determine the constant pointer and the size (amount of info to + copy). */ + +void +ffebld_constantarray_prepare (void **aptr, void **cptr, size_t *size, + ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt, + ffetargetOffset offset, ffebldConstantUnion *constant, + ffeinfoBasictype cbt, ffeinfoKindtype ckt) +{ + switch (abt) + { + case FFEINFO_basictypeINTEGER: + switch (akt) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + *aptr = array.integer1 + offset; + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + *aptr = array.integer2 + offset; + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + *aptr = array.integer3 + offset; + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + *aptr = array.integer4 + offset; + break; +#endif + +#if FFETARGET_okINTEGER5 + case FFEINFO_kindtypeINTEGER5: + *aptr = array.integer5 + offset; + break; +#endif + +#if FFETARGET_okINTEGER6 + case FFEINFO_kindtypeINTEGER6: + *aptr = array.integer6 + offset; + break; +#endif + +#if FFETARGET_okINTEGER7 + case FFEINFO_kindtypeINTEGER7: + *aptr = array.integer7 + offset; + break; +#endif + +#if FFETARGET_okINTEGER8 + case FFEINFO_kindtypeINTEGER8: + *aptr = array.integer8 + offset; + break; +#endif + + default: + assert ("bad INTEGER akindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + switch (akt) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + *aptr = array.logical1 + offset; + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + *aptr = array.logical2 + offset; + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + *aptr = array.logical3 + offset; + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + *aptr = array.logical4 + offset; + break; +#endif + +#if FFETARGET_okLOGICAL5 + case FFEINFO_kindtypeLOGICAL5: + *aptr = array.logical5 + offset; + break; +#endif + +#if FFETARGET_okLOGICAL6 + case FFEINFO_kindtypeLOGICAL6: + *aptr = array.logical6 + offset; + break; +#endif + +#if FFETARGET_okLOGICAL7 + case FFEINFO_kindtypeLOGICAL7: + *aptr = array.logical7 + offset; + break; +#endif + +#if FFETARGET_okLOGICAL8 + case FFEINFO_kindtypeLOGICAL8: + *aptr = array.logical8 + offset; + break; +#endif + + default: + assert ("bad LOGICAL akindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (akt) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + *aptr = array.real1 + offset; + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + *aptr = array.real2 + offset; + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + *aptr = array.real3 + offset; + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + *aptr = array.real4 + offset; + break; +#endif + +#if FFETARGET_okREAL5 + case FFEINFO_kindtypeREAL5: + *aptr = array.real5 + offset; + break; +#endif + +#if FFETARGET_okREAL6 + case FFEINFO_kindtypeREAL6: + *aptr = array.real6 + offset; + break; +#endif + +#if FFETARGET_okREAL7 + case FFEINFO_kindtypeREAL7: + *aptr = array.real7 + offset; + break; +#endif + +#if FFETARGET_okREAL8 + case FFEINFO_kindtypeREAL8: + *aptr = array.real8 + offset; + break; +#endif + + default: + assert ("bad REAL akindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (akt) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + *aptr = array.complex1 + offset; + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + *aptr = array.complex2 + offset; + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + *aptr = array.complex3 + offset; + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + *aptr = array.complex4 + offset; + break; +#endif + +#if FFETARGET_okCOMPLEX5 + case FFEINFO_kindtypeREAL5: + *aptr = array.complex5 + offset; + break; +#endif + +#if FFETARGET_okCOMPLEX6 + case FFEINFO_kindtypeREAL6: + *aptr = array.complex6 + offset; + break; +#endif + +#if FFETARGET_okCOMPLEX7 + case FFEINFO_kindtypeREAL7: + *aptr = array.complex7 + offset; + break; +#endif + +#if FFETARGET_okCOMPLEX8 + case FFEINFO_kindtypeREAL8: + *aptr = array.complex8 + offset; + break; +#endif + + default: + assert ("bad COMPLEX akindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + switch (akt) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeCHARACTER1: + *aptr = array.character1 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER2 + case FFEINFO_kindtypeCHARACTER2: + *aptr = array.character2 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER3 + case FFEINFO_kindtypeCHARACTER3: + *aptr = array.character3 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER4 + case FFEINFO_kindtypeCHARACTER4: + *aptr = array.character4 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER5 + case FFEINFO_kindtypeCHARACTER5: + *aptr = array.character5 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER6 + case FFEINFO_kindtypeCHARACTER6: + *aptr = array.character6 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER7 + case FFEINFO_kindtypeCHARACTER7: + *aptr = array.character7 + offset; + break; +#endif + +#if FFETARGET_okCHARACTER8 + case FFEINFO_kindtypeCHARACTER8: + *aptr = array.character8 + offset; + break; +#endif + + default: + assert ("bad CHARACTER akindtype" == NULL); + break; + } + break; + + default: + assert ("bad abasictype" == NULL); + break; + } + + switch (cbt) + { + case FFEINFO_basictypeINTEGER: + switch (ckt) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + *cptr = &constant->integer1; + *size = sizeof (constant->integer1); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + *cptr = &constant->integer2; + *size = sizeof (constant->integer2); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + *cptr = &constant->integer3; + *size = sizeof (constant->integer3); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + *cptr = &constant->integer4; + *size = sizeof (constant->integer4); + break; +#endif + +#if FFETARGET_okINTEGER5 + case FFEINFO_kindtypeINTEGER5: + *cptr = &constant->integer5; + *size = sizeof (constant->integer5); + break; +#endif + +#if FFETARGET_okINTEGER6 + case FFEINFO_kindtypeINTEGER6: + *cptr = &constant->integer6; + *size = sizeof (constant->integer6); + break; +#endif + +#if FFETARGET_okINTEGER7 + case FFEINFO_kindtypeINTEGER7: + *cptr = &constant->integer7; + *size = sizeof (constant->integer7); + break; +#endif + +#if FFETARGET_okINTEGER8 + case FFEINFO_kindtypeINTEGER8: + *cptr = &constant->integer8; + *size = sizeof (constant->integer8); + break; +#endif + + default: + assert ("bad INTEGER ckindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + switch (ckt) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + *cptr = &constant->logical1; + *size = sizeof (constant->logical1); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + *cptr = &constant->logical2; + *size = sizeof (constant->logical2); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + *cptr = &constant->logical3; + *size = sizeof (constant->logical3); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + *cptr = &constant->logical4; + *size = sizeof (constant->logical4); + break; +#endif + +#if FFETARGET_okLOGICAL5 + case FFEINFO_kindtypeLOGICAL5: + *cptr = &constant->logical5; + *size = sizeof (constant->logical5); + break; +#endif + +#if FFETARGET_okLOGICAL6 + case FFEINFO_kindtypeLOGICAL6: + *cptr = &constant->logical6; + *size = sizeof (constant->logical6); + break; +#endif + +#if FFETARGET_okLOGICAL7 + case FFEINFO_kindtypeLOGICAL7: + *cptr = &constant->logical7; + *size = sizeof (constant->logical7); + break; +#endif + +#if FFETARGET_okLOGICAL8 + case FFEINFO_kindtypeLOGICAL8: + *cptr = &constant->logical8; + *size = sizeof (constant->logical8); + break; +#endif + + default: + assert ("bad LOGICAL ckindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ckt) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + *cptr = &constant->real1; + *size = sizeof (constant->real1); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + *cptr = &constant->real2; + *size = sizeof (constant->real2); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + *cptr = &constant->real3; + *size = sizeof (constant->real3); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + *cptr = &constant->real4; + *size = sizeof (constant->real4); + break; +#endif + +#if FFETARGET_okREAL5 + case FFEINFO_kindtypeREAL5: + *cptr = &constant->real5; + *size = sizeof (constant->real5); + break; +#endif + +#if FFETARGET_okREAL6 + case FFEINFO_kindtypeREAL6: + *cptr = &constant->real6; + *size = sizeof (constant->real6); + break; +#endif + +#if FFETARGET_okREAL7 + case FFEINFO_kindtypeREAL7: + *cptr = &constant->real7; + *size = sizeof (constant->real7); + break; +#endif + +#if FFETARGET_okREAL8 + case FFEINFO_kindtypeREAL8: + *cptr = &constant->real8; + *size = sizeof (constant->real8); + break; +#endif + + default: + assert ("bad REAL ckindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (ckt) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + *cptr = &constant->complex1; + *size = sizeof (constant->complex1); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + *cptr = &constant->complex2; + *size = sizeof (constant->complex2); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + *cptr = &constant->complex3; + *size = sizeof (constant->complex3); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + *cptr = &constant->complex4; + *size = sizeof (constant->complex4); + break; +#endif + +#if FFETARGET_okCOMPLEX5 + case FFEINFO_kindtypeREAL5: + *cptr = &constant->complex5; + *size = sizeof (constant->complex5); + break; +#endif + +#if FFETARGET_okCOMPLEX6 + case FFEINFO_kindtypeREAL6: + *cptr = &constant->complex6; + *size = sizeof (constant->complex6); + break; +#endif + +#if FFETARGET_okCOMPLEX7 + case FFEINFO_kindtypeREAL7: + *cptr = &constant->complex7; + *size = sizeof (constant->complex7); + break; +#endif + +#if FFETARGET_okCOMPLEX8 + case FFEINFO_kindtypeREAL8: + *cptr = &constant->complex8; + *size = sizeof (constant->complex8); + break; +#endif + + default: + assert ("bad COMPLEX ckindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + switch (ckt) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeCHARACTER1: + *cptr = ffetarget_text_character1 (constant->character1); + *size = ffetarget_length_character1 (constant->character1); + break; +#endif + +#if FFETARGET_okCHARACTER2 + case FFEINFO_kindtypeCHARACTER2: + *cptr = ffetarget_text_character2 (constant->character2); + *size = ffetarget_length_character2 (constant->character2); + break; +#endif + +#if FFETARGET_okCHARACTER3 + case FFEINFO_kindtypeCHARACTER3: + *cptr = ffetarget_text_character3 (constant->character3); + *size = ffetarget_length_character3 (constant->character3); + break; +#endif + +#if FFETARGET_okCHARACTER4 + case FFEINFO_kindtypeCHARACTER4: + *cptr = ffetarget_text_character4 (constant->character4); + *size = ffetarget_length_character4 (constant->character4); + break; +#endif + +#if FFETARGET_okCHARACTER5 + case FFEINFO_kindtypeCHARACTER5: + *cptr = ffetarget_text_character5 (constant->character5); + *size = ffetarget_length_character5 (constant->character5); + break; +#endif + +#if FFETARGET_okCHARACTER6 + case FFEINFO_kindtypeCHARACTER6: + *cptr = ffetarget_text_character6 (constant->character6); + *size = ffetarget_length_character6 (constant->character6); + break; +#endif + +#if FFETARGET_okCHARACTER7 + case FFEINFO_kindtypeCHARACTER7: + *cptr = ffetarget_text_character7 (constant->character7); + *size = ffetarget_length_character7 (constant->character7); + break; +#endif + +#if FFETARGET_okCHARACTER8 + case FFEINFO_kindtypeCHARACTER8: + *cptr = ffetarget_text_character8 (constant->character8); + *size = ffetarget_length_character8 (constant->character8); + break; +#endif + + default: + assert ("bad CHARACTER ckindtype" == NULL); + break; + } + break; + + default: + assert ("bad cbasictype" == NULL); + break; + } +} + +/* ffebld_constantarray_put -- Put a value into an array of constants + + See prototype. */ + +void +ffebld_constantarray_put (ffebldConstantArray array, ffeinfoBasictype bt, + ffeinfoKindtype kt, ffetargetOffset offset, ffebldConstantUnion constant) +{ + switch (bt) + { + case FFEINFO_basictypeINTEGER: + switch (kt) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + *(array.integer1 + offset) = constant.integer1; + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + *(array.integer2 + offset) = constant.integer2; + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + *(array.integer3 + offset) = constant.integer3; + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + *(array.integer4 + offset) = constant.integer4; + break; +#endif + +#if FFETARGET_okINTEGER5 + case FFEINFO_kindtypeINTEGER5: + *(array.integer5 + offset) = constant.integer5; + break; +#endif + +#if FFETARGET_okINTEGER6 + case FFEINFO_kindtypeINTEGER6: + *(array.integer6 + offset) = constant.integer6; + break; +#endif + +#if FFETARGET_okINTEGER7 + case FFEINFO_kindtypeINTEGER7: + *(array.integer7 + offset) = constant.integer7; + break; +#endif + +#if FFETARGET_okINTEGER8 + case FFEINFO_kindtypeINTEGER8: + *(array.integer8 + offset) = constant.integer8; + break; +#endif + + default: + assert ("bad INTEGER kindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + switch (kt) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + *(array.logical1 + offset) = constant.logical1; + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + *(array.logical2 + offset) = constant.logical2; + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + *(array.logical3 + offset) = constant.logical3; + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + *(array.logical4 + offset) = constant.logical4; + break; +#endif + +#if FFETARGET_okLOGICAL5 + case FFEINFO_kindtypeLOGICAL5: + *(array.logical5 + offset) = constant.logical5; + break; +#endif + +#if FFETARGET_okLOGICAL6 + case FFEINFO_kindtypeLOGICAL6: + *(array.logical6 + offset) = constant.logical6; + break; +#endif + +#if FFETARGET_okLOGICAL7 + case FFEINFO_kindtypeLOGICAL7: + *(array.logical7 + offset) = constant.logical7; + break; +#endif + +#if FFETARGET_okLOGICAL8 + case FFEINFO_kindtypeLOGICAL8: + *(array.logical8 + offset) = constant.logical8; + break; +#endif + + default: + assert ("bad LOGICAL kindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (kt) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + *(array.real1 + offset) = constant.real1; + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + *(array.real2 + offset) = constant.real2; + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + *(array.real3 + offset) = constant.real3; + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + *(array.real4 + offset) = constant.real4; + break; +#endif + +#if FFETARGET_okREAL5 + case FFEINFO_kindtypeREAL5: + *(array.real5 + offset) = constant.real5; + break; +#endif + +#if FFETARGET_okREAL6 + case FFEINFO_kindtypeREAL6: + *(array.real6 + offset) = constant.real6; + break; +#endif + +#if FFETARGET_okREAL7 + case FFEINFO_kindtypeREAL7: + *(array.real7 + offset) = constant.real7; + break; +#endif + +#if FFETARGET_okREAL8 + case FFEINFO_kindtypeREAL8: + *(array.real8 + offset) = constant.real8; + break; +#endif + + default: + assert ("bad REAL kindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (kt) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + *(array.complex1 + offset) = constant.complex1; + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + *(array.complex2 + offset) = constant.complex2; + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + *(array.complex3 + offset) = constant.complex3; + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + *(array.complex4 + offset) = constant.complex4; + break; +#endif + +#if FFETARGET_okCOMPLEX5 + case FFEINFO_kindtypeREAL5: + *(array.complex5 + offset) = constant.complex5; + break; +#endif + +#if FFETARGET_okCOMPLEX6 + case FFEINFO_kindtypeREAL6: + *(array.complex6 + offset) = constant.complex6; + break; +#endif + +#if FFETARGET_okCOMPLEX7 + case FFEINFO_kindtypeREAL7: + *(array.complex7 + offset) = constant.complex7; + break; +#endif + +#if FFETARGET_okCOMPLEX8 + case FFEINFO_kindtypeREAL8: + *(array.complex8 + offset) = constant.complex8; + break; +#endif + + default: + assert ("bad COMPLEX kindtype" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + switch (kt) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeCHARACTER1: + memcpy (array.character1 + offset, + ffetarget_text_character1 (constant.character1), + ffetarget_length_character1 (constant.character1)); + break; +#endif + +#if FFETARGET_okCHARACTER2 + case FFEINFO_kindtypeCHARACTER2: + memcpy (array.character2 + offset, + ffetarget_text_character2 (constant.character2), + ffetarget_length_character2 (constant.character2)); + break; +#endif + +#if FFETARGET_okCHARACTER3 + case FFEINFO_kindtypeCHARACTER3: + memcpy (array.character3 + offset, + ffetarget_text_character3 (constant.character3), + ffetarget_length_character3 (constant.character3)); + break; +#endif + +#if FFETARGET_okCHARACTER4 + case FFEINFO_kindtypeCHARACTER4: + memcpy (array.character4 + offset, + ffetarget_text_character4 (constant.character4), + ffetarget_length_character4 (constant.character4)); + break; +#endif + +#if FFETARGET_okCHARACTER5 + case FFEINFO_kindtypeCHARACTER5: + memcpy (array.character5 + offset, + ffetarget_text_character5 (constant.character5), + ffetarget_length_character5 (constant.character5)); + break; +#endif + +#if FFETARGET_okCHARACTER6 + case FFEINFO_kindtypeCHARACTER6: + memcpy (array.character6 + offset, + ffetarget_text_character6 (constant.character6), + ffetarget_length_character6 (constant.character6)); + break; +#endif + +#if FFETARGET_okCHARACTER7 + case FFEINFO_kindtypeCHARACTER7: + memcpy (array.character7 + offset, + ffetarget_text_character7 (constant.character7), + ffetarget_length_character7 (constant.character7)); + break; +#endif + +#if FFETARGET_okCHARACTER8 + case FFEINFO_kindtypeCHARACTER8: + memcpy (array.character8 + offset, + ffetarget_text_character8 (constant.character8), + ffetarget_length_character8 (constant.character8)); + break; +#endif + + default: + assert ("bad CHARACTER kindtype" == NULL); + break; + } + break; + + default: + assert ("bad basictype" == NULL); + break; + } +} + +/* ffebld_constantunion_dump -- Dump a constant + + See prototype. */ + +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; + } +} + +/* ffebld_dump -- Dump expression tree in concise form + + ffebld b; + ffebld_dump(b); */ + +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; + } + } +} + +/* ffebld_dump_prefix -- Dump the prefix for a constant of a given type + + ffebld_dump_prefix(dmpout,FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGER1); */ + +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; + } +} + +/* ffebld_init_0 -- Initialize the module + + ffebld_init_0(); */ + +void +ffebld_init_0 () +{ + assert (FFEBLD_op == ARRAY_SIZE (ffebld_op_string_)); + assert (FFEBLD_op == ARRAY_SIZE (ffebld_arity_op_)); +} + +/* ffebld_init_1 -- Initialize the module for a file + + ffebld_init_1(); */ + +void +ffebld_init_1 () +{ +#if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstFILE_ + int i; + +#if FFETARGET_okCHARACTER1 + ffebld_constant_character1_ = NULL; +#endif +#if FFETARGET_okCHARACTER2 + ffebld_constant_character2_ = NULL; +#endif +#if FFETARGET_okCHARACTER3 + ffebld_constant_character3_ = NULL; +#endif +#if FFETARGET_okCHARACTER4 + ffebld_constant_character4_ = NULL; +#endif +#if FFETARGET_okCHARACTER5 + ffebld_constant_character5_ = NULL; +#endif +#if FFETARGET_okCHARACTER6 + ffebld_constant_character6_ = NULL; +#endif +#if FFETARGET_okCHARACTER7 + ffebld_constant_character7_ = NULL; +#endif +#if FFETARGET_okCHARACTER8 + ffebld_constant_character8_ = NULL; +#endif +#if FFETARGET_okCOMPLEX1 + ffebld_constant_complex1_ = NULL; +#endif +#if FFETARGET_okCOMPLEX2 + ffebld_constant_complex2_ = NULL; +#endif +#if FFETARGET_okCOMPLEX3 + ffebld_constant_complex3_ = NULL; +#endif +#if FFETARGET_okCOMPLEX4 + ffebld_constant_complex4_ = NULL; +#endif +#if FFETARGET_okCOMPLEX5 + ffebld_constant_complex5_ = NULL; +#endif +#if FFETARGET_okCOMPLEX6 + ffebld_constant_complex6_ = NULL; +#endif +#if FFETARGET_okCOMPLEX7 + ffebld_constant_complex7_ = NULL; +#endif +#if FFETARGET_okCOMPLEX8 + ffebld_constant_complex8_ = NULL; +#endif +#if FFETARGET_okINTEGER1 + ffebld_constant_integer1_ = NULL; +#endif +#if FFETARGET_okINTEGER2 + ffebld_constant_integer2_ = NULL; +#endif +#if FFETARGET_okINTEGER3 + ffebld_constant_integer3_ = NULL; +#endif +#if FFETARGET_okINTEGER4 + ffebld_constant_integer4_ = NULL; +#endif +#if FFETARGET_okINTEGER5 + ffebld_constant_integer5_ = NULL; +#endif +#if FFETARGET_okINTEGER6 + ffebld_constant_integer6_ = NULL; +#endif +#if FFETARGET_okINTEGER7 + ffebld_constant_integer7_ = NULL; +#endif +#if FFETARGET_okINTEGER8 + ffebld_constant_integer8_ = NULL; +#endif +#if FFETARGET_okLOGICAL1 + ffebld_constant_logical1_ = NULL; +#endif +#if FFETARGET_okLOGICAL2 + ffebld_constant_logical2_ = NULL; +#endif +#if FFETARGET_okLOGICAL3 + ffebld_constant_logical3_ = NULL; +#endif +#if FFETARGET_okLOGICAL4 + ffebld_constant_logical4_ = NULL; +#endif +#if FFETARGET_okLOGICAL5 + ffebld_constant_logical5_ = NULL; +#endif +#if FFETARGET_okLOGICAL6 + ffebld_constant_logical6_ = NULL; +#endif +#if FFETARGET_okLOGICAL7 + ffebld_constant_logical7_ = NULL; +#endif +#if FFETARGET_okLOGICAL8 + ffebld_constant_logical8_ = NULL; +#endif +#if FFETARGET_okREAL1 + ffebld_constant_real1_ = NULL; +#endif +#if FFETARGET_okREAL2 + ffebld_constant_real2_ = NULL; +#endif +#if FFETARGET_okREAL3 + ffebld_constant_real3_ = NULL; +#endif +#if FFETARGET_okREAL4 + ffebld_constant_real4_ = NULL; +#endif +#if FFETARGET_okREAL5 + ffebld_constant_real5_ = NULL; +#endif +#if FFETARGET_okREAL6 + ffebld_constant_real6_ = NULL; +#endif +#if FFETARGET_okREAL7 + ffebld_constant_real7_ = NULL; +#endif +#if FFETARGET_okREAL8 + ffebld_constant_real8_ = NULL; +#endif + ffebld_constant_hollerith_ = NULL; + for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i) + ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL; +#endif +} + +/* ffebld_init_2 -- Initialize the module + + ffebld_init_2(); */ + +void +ffebld_init_2 () +{ +#if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_ + int i; +#endif + + ffebld_pool_stack_.next = NULL; + ffebld_pool_stack_.pool = ffe_pool_program_unit (); +#if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_ +#if FFETARGET_okCHARACTER1 + ffebld_constant_character1_ = NULL; +#endif +#if FFETARGET_okCHARACTER2 + ffebld_constant_character2_ = NULL; +#endif +#if FFETARGET_okCHARACTER3 + ffebld_constant_character3_ = NULL; +#endif +#if FFETARGET_okCHARACTER4 + ffebld_constant_character4_ = NULL; +#endif +#if FFETARGET_okCHARACTER5 + ffebld_constant_character5_ = NULL; +#endif +#if FFETARGET_okCHARACTER6 + ffebld_constant_character6_ = NULL; +#endif +#if FFETARGET_okCHARACTER7 + ffebld_constant_character7_ = NULL; +#endif +#if FFETARGET_okCHARACTER8 + ffebld_constant_character8_ = NULL; +#endif +#if FFETARGET_okCOMPLEX1 + ffebld_constant_complex1_ = NULL; +#endif +#if FFETARGET_okCOMPLEX2 + ffebld_constant_complex2_ = NULL; +#endif +#if FFETARGET_okCOMPLEX3 + ffebld_constant_complex3_ = NULL; +#endif +#if FFETARGET_okCOMPLEX4 + ffebld_constant_complex4_ = NULL; +#endif +#if FFETARGET_okCOMPLEX5 + ffebld_constant_complex5_ = NULL; +#endif +#if FFETARGET_okCOMPLEX6 + ffebld_constant_complex6_ = NULL; +#endif +#if FFETARGET_okCOMPLEX7 + ffebld_constant_complex7_ = NULL; +#endif +#if FFETARGET_okCOMPLEX8 + ffebld_constant_complex8_ = NULL; +#endif +#if FFETARGET_okINTEGER1 + ffebld_constant_integer1_ = NULL; +#endif +#if FFETARGET_okINTEGER2 + ffebld_constant_integer2_ = NULL; +#endif +#if FFETARGET_okINTEGER3 + ffebld_constant_integer3_ = NULL; +#endif +#if FFETARGET_okINTEGER4 + ffebld_constant_integer4_ = NULL; +#endif +#if FFETARGET_okINTEGER5 + ffebld_constant_integer5_ = NULL; +#endif +#if FFETARGET_okINTEGER6 + ffebld_constant_integer6_ = NULL; +#endif +#if FFETARGET_okINTEGER7 + ffebld_constant_integer7_ = NULL; +#endif +#if FFETARGET_okINTEGER8 + ffebld_constant_integer8_ = NULL; +#endif +#if FFETARGET_okLOGICAL1 + ffebld_constant_logical1_ = NULL; +#endif +#if FFETARGET_okLOGICAL2 + ffebld_constant_logical2_ = NULL; +#endif +#if FFETARGET_okLOGICAL3 + ffebld_constant_logical3_ = NULL; +#endif +#if FFETARGET_okLOGICAL4 + ffebld_constant_logical4_ = NULL; +#endif +#if FFETARGET_okLOGICAL5 + ffebld_constant_logical5_ = NULL; +#endif +#if FFETARGET_okLOGICAL6 + ffebld_constant_logical6_ = NULL; +#endif +#if FFETARGET_okLOGICAL7 + ffebld_constant_logical7_ = NULL; +#endif +#if FFETARGET_okLOGICAL8 + ffebld_constant_logical8_ = NULL; +#endif +#if FFETARGET_okREAL1 + ffebld_constant_real1_ = NULL; +#endif +#if FFETARGET_okREAL2 + ffebld_constant_real2_ = NULL; +#endif +#if FFETARGET_okREAL3 + ffebld_constant_real3_ = NULL; +#endif +#if FFETARGET_okREAL4 + ffebld_constant_real4_ = NULL; +#endif +#if FFETARGET_okREAL5 + ffebld_constant_real5_ = NULL; +#endif +#if FFETARGET_okREAL6 + ffebld_constant_real6_ = NULL; +#endif +#if FFETARGET_okREAL7 + ffebld_constant_real7_ = NULL; +#endif +#if FFETARGET_okREAL8 + ffebld_constant_real8_ = NULL; +#endif + ffebld_constant_hollerith_ = NULL; + for (i = FFEBLD_constTYPELESS_FIRST; i <= FFEBLD_constTYPELESS_LAST; ++i) + ffebld_constant_typeless_[i - FFEBLD_constTYPELESS_FIRST] = NULL; +#endif +} + +/* ffebld_list_length -- Return # of opITEMs in list + + ffebld list; // Must be NULL or opITEM + ffebldListLength length; + length = ffebld_list_length(list); + + Returns 0 if list is NULL, 1 if it's ffebld_trail is NULL, and so on. */ + +ffebldListLength +ffebld_list_length (ffebld list) +{ + ffebldListLength length; + + for (length = 0; list != NULL; ++length, list = ffebld_trail (list)) + ; + + return length; +} + +/* ffebld_new_accter -- Create an ffebld object that is an array + + ffebld x; + ffebldConstantArray a; + ffebit b; + x = ffebld_new_accter(a,b); */ + +ffebld +ffebld_new_accter (ffebldConstantArray a, ffebit b) +{ + ffebld x; + + x = ffebld_new (); +#if FFEBLD_BLANK_ + *x = ffebld_blank_; +#endif + x->op = FFEBLD_opACCTER; + x->u.accter.array = a; + x->u.accter.bits = b; + return x; +} + +/* ffebld_new_arrter -- Create an ffebld object that is an array + + ffebld x; + ffebldConstantArray a; + ffetargetOffset size; + x = ffebld_new_arrter(a,size); */ + +ffebld +ffebld_new_arrter (ffebldConstantArray a, ffetargetOffset size) +{ + ffebld x; + + x = ffebld_new (); +#if FFEBLD_BLANK_ + *x = ffebld_blank_; +#endif + x->op = FFEBLD_opARRTER; + x->u.arrter.array = a; + x->u.arrter.size = size; + return x; +} + +/* ffebld_new_conter_with_orig -- Create an ffebld object that is a constant + + ffebld x; + ffebldConstant c; + x = ffebld_new_conter_with_orig(c,NULL); */ + +ffebld +ffebld_new_conter_with_orig (ffebldConstant c, ffebld o) +{ + ffebld x; + + x = ffebld_new (); +#if FFEBLD_BLANK_ + *x = ffebld_blank_; +#endif + x->op = FFEBLD_opCONTER; + x->u.conter.expr = c; + x->u.conter.orig = o; + return x; +} + +/* ffebld_new_item -- Create an ffebld item object + + ffebld x,y,z; + x = ffebld_new_item(y,z); */ + +ffebld +ffebld_new_item (ffebld head, ffebld trail) +{ + ffebld x; + + x = ffebld_new (); +#if FFEBLD_BLANK_ + *x = ffebld_blank_; +#endif + x->op = FFEBLD_opITEM; + x->u.item.head = head; + x->u.item.trail = trail; + return x; +} + +/* ffebld_new_labter -- Create an ffebld object that is a label + + ffebld x; + ffelab l; + x = ffebld_new_labter(c); */ + +ffebld +ffebld_new_labter (ffelab l) +{ + ffebld x; + + x = ffebld_new (); +#if FFEBLD_BLANK_ + *x = ffebld_blank_; +#endif + x->op = FFEBLD_opLABTER; + x->u.labter = l; + return x; +} + +/* ffebld_new_labtok -- Create object that is a label's NUMBER token + + ffebld x; + ffelexToken t; + x = ffebld_new_labter(c); + + Like the other ffebld_new_ functions, the + supplied argument is stored exactly as is: ffelex_token_use is NOT + called, so the token is "consumed", if one is indeed supplied (it may + be NULL). */ + +ffebld +ffebld_new_labtok (ffelexToken t) +{ + ffebld x; + + x = ffebld_new (); +#if FFEBLD_BLANK_ + *x = ffebld_blank_; +#endif + x->op = FFEBLD_opLABTOK; + x->u.labtok = t; + return x; +} + +/* ffebld_new_none -- Create an ffebld object with no arguments + + ffebld x; + x = ffebld_new_none(FFEBLD_opWHATEVER); */ + +ffebld +ffebld_new_none (ffebldOp o) +{ + ffebld x; + + x = ffebld_new (); +#if FFEBLD_BLANK_ + *x = ffebld_blank_; +#endif + x->op = o; + return x; +} + +/* ffebld_new_one -- Create an ffebld object with one argument + + ffebld x,y; + x = ffebld_new_one(FFEBLD_opWHATEVER,y); */ + +ffebld +ffebld_new_one (ffebldOp o, ffebld left) +{ + ffebld x; + + x = ffebld_new (); +#if FFEBLD_BLANK_ + *x = ffebld_blank_; +#endif + x->op = o; + x->u.nonter.left = left; + return x; +} + +/* ffebld_new_symter -- Create an ffebld object that is a symbol + + ffebld x; + ffesymbol s; + ffeintrinGen gen; // Generic intrinsic id, if any + ffeintrinSpec spec; // Specific intrinsic id, if any + ffeintrinImp imp; // Implementation intrinsic id, if any + x = ffebld_new_symter (s, gen, spec, imp); */ + +ffebld +ffebld_new_symter (ffesymbol s, ffeintrinGen gen, ffeintrinSpec spec, + ffeintrinImp imp) +{ + ffebld x; + + x = ffebld_new (); +#if FFEBLD_BLANK_ + *x = ffebld_blank_; +#endif + x->op = FFEBLD_opSYMTER; + x->u.symter.symbol = s; + x->u.symter.generic = gen; + x->u.symter.specific = spec; + x->u.symter.implementation = imp; + x->u.symter.do_iter = FALSE; + return x; +} + +/* ffebld_new_two -- Create an ffebld object with two arguments + + ffebld x,y,z; + x = ffebld_new_two(FFEBLD_opWHATEVER,y,z); */ + +ffebld +ffebld_new_two (ffebldOp o, ffebld left, ffebld right) +{ + ffebld x; + + x = ffebld_new (); +#if FFEBLD_BLANK_ + *x = ffebld_blank_; +#endif + x->op = o; + x->u.nonter.left = left; + x->u.nonter.right = right; + return x; +} + +/* ffebld_pool_pop -- Pop ffebld's pool stack + + ffebld_pool_pop(); */ + +void +ffebld_pool_pop () +{ + ffebldPoolstack_ ps; + + assert (ffebld_pool_stack_.next != NULL); + ps = ffebld_pool_stack_.next; + ffebld_pool_stack_.next = ps->next; + ffebld_pool_stack_.pool = ps->pool; + malloc_kill_ks (malloc_pool_image (), ps, sizeof (*ps)); +} + +/* ffebld_pool_push -- Push ffebld's pool stack + + ffebld_pool_push(); */ + +void +ffebld_pool_push (mallocPool pool) +{ + ffebldPoolstack_ ps; + + ps = malloc_new_ks (malloc_pool_image (), "Pool stack", sizeof (*ps)); + ps->next = ffebld_pool_stack_.next; + ps->pool = ffebld_pool_stack_.pool; + ffebld_pool_stack_.next = ps; + ffebld_pool_stack_.pool = pool; +} + +/* ffebld_op_string -- Return short string describing op + + ffebldOp o; + ffebld_op_string(o); + + Returns a short string (uppercase) containing the name of the op. */ + +char * +ffebld_op_string (ffebldOp o) +{ + if (o >= ARRAY_SIZE (ffebld_op_string_)) + return "?\?\?"; + return ffebld_op_string_[o]; +} + +/* ffebld_size_max -- Return maximum possible size of CHARACTER-type expr + + ffetargetCharacterSize sz; + ffebld b; + sz = ffebld_size_max (b); + + Like ffebld_size_known, but if that would return NONE and the expression + is opSUBSTR, opCONVERT, opPAREN, or opCONCATENATE, returns ffebld_size_max + of the subexpression(s). */ + +ffetargetCharacterSize +ffebld_size_max (ffebld b) +{ + ffetargetCharacterSize sz; + +recurse: /* :::::::::::::::::::: */ + + sz = ffebld_size_known (b); + + if (sz != FFETARGET_charactersizeNONE) + return sz; + + switch (ffebld_op (b)) + { + case FFEBLD_opSUBSTR: + case FFEBLD_opCONVERT: + case FFEBLD_opPAREN: + b = ffebld_left (b); + goto recurse; /* :::::::::::::::::::: */ + + case FFEBLD_opCONCATENATE: + sz = ffebld_size_max (ffebld_left (b)) + + ffebld_size_max (ffebld_right (b)); + return sz; + + default: + return sz; + } +} diff --git a/gcc/f/bld.h b/gcc/f/bld.h new file mode 100644 index 000000000000..a9dbe9f2e03a --- /dev/null +++ b/gcc/f/bld.h @@ -0,0 +1,1009 @@ +/* bld.h -- Public #include File (module.h template V1.0) + Copyright (C) 1995, 1996 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + bld.c + + Modifications: +*/ + +/* Allow multiple inclusion to work. */ + +#ifndef _H_f_bld +#define _H_f_bld + +/* Simple definitions and enumerations. */ + +typedef enum + { + FFEBLD_constNONE, + FFEBLD_constINTEGER1, + FFEBLD_constINTEGER2, + FFEBLD_constINTEGER3, + FFEBLD_constINTEGER4, + FFEBLD_constINTEGER5, + FFEBLD_constINTEGER6, + FFEBLD_constINTEGER7, + FFEBLD_constINTEGER8, + FFEBLD_constLOGICAL1, + FFEBLD_constLOGICAL2, + FFEBLD_constLOGICAL3, + FFEBLD_constLOGICAL4, + FFEBLD_constLOGICAL5, + FFEBLD_constLOGICAL6, + FFEBLD_constLOGICAL7, + FFEBLD_constLOGICAL8, + FFEBLD_constREAL1, + FFEBLD_constREAL2, + FFEBLD_constREAL3, + FFEBLD_constREAL4, + FFEBLD_constREAL5, + FFEBLD_constREAL6, + FFEBLD_constREAL7, + FFEBLD_constREAL8, + FFEBLD_constCOMPLEX1, + FFEBLD_constCOMPLEX2, + FFEBLD_constCOMPLEX3, + FFEBLD_constCOMPLEX4, + FFEBLD_constCOMPLEX5, + FFEBLD_constCOMPLEX6, + FFEBLD_constCOMPLEX7, + FFEBLD_constCOMPLEX8, + FFEBLD_constCHARACTER1, + FFEBLD_constCHARACTER2, + FFEBLD_constCHARACTER3, + FFEBLD_constCHARACTER4, + FFEBLD_constCHARACTER5, + FFEBLD_constCHARACTER6, + FFEBLD_constCHARACTER7, + FFEBLD_constCHARACTER8, + FFEBLD_constHOLLERITH, + FFEBLD_constTYPELESS_FIRST, + FFEBLD_constBINARY_MIL = FFEBLD_constTYPELESS_FIRST, + FFEBLD_constBINARY_VXT, + FFEBLD_constOCTAL_MIL, + FFEBLD_constOCTAL_VXT, + FFEBLD_constHEX_X_MIL, + FFEBLD_constHEX_X_VXT, + FFEBLD_constHEX_Z_MIL, + FFEBLD_constHEX_Z_VXT, + FFEBLD_constTYPELESS_LAST = FFEBLD_constHEX_Z_VXT, + FFEBLD_const + } ffebldConst; + +typedef enum + { +#define FFEBLD_OP(KWD,NAME,ARITY) KWD, +#include "bld-op.def" +#undef FFEBLD_OP + FFEBLD_op + } ffebldOp; + +/* Typedefs. */ + +typedef struct _ffebld_ *ffebld; +typedef unsigned char ffebldArity; +typedef union _ffebld_constant_array_ ffebldConstantArray; +typedef struct _ffebld_constant_ *ffebldConstant; +typedef union _ffebld_constant_union_ ffebldConstantUnion; +typedef ffebld *ffebldListBottom; +typedef unsigned int ffebldListLength; +#define ffebldListLength_f "" +typedef struct _ffebld_pool_stack_ *ffebldPoolstack_; + +/* Include files needed by this one. */ + +#include "bit.h" +#include "com.h" +#include "info.h" +#include "intrin.h" +#include "lab.h" +#include "lex.h" +#include "malloc.h" +#include "symbol.h" +#include "target.h" + +#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. */ + +#define FFEBLD_constINTEGERDEFAULT FFEBLD_constINTEGER1 +#define FFEBLD_constLOGICALDEFAULT FFEBLD_constLOGICAL1 +#define FFEBLD_constREALDEFAULT FFEBLD_constREAL1 +#define FFEBLD_constREALDOUBLE FFEBLD_constREAL2 +#define FFEBLD_constREALQUAD FFEBLD_constREAL3 +#define FFEBLD_constCOMPLEX FFEBLD_constCOMPLEX1 +#define FFEBLD_constCOMPLEXDOUBLE FFEBLD_constCOMPLEX2 +#define FFEBLD_constCOMPLEXQUAD FFEBLD_constCOMPLEX3 +#define FFEBLD_constCHARACTERDEFAULT FFEBLD_constCHARACTER1 + +union _ffebld_constant_union_ + { + ffetargetTypeless typeless; + ffetargetHollerith hollerith; +#if FFETARGET_okINTEGER1 + ffetargetInteger1 integer1; +#endif +#if FFETARGET_okINTEGER2 + ffetargetInteger2 integer2; +#endif +#if FFETARGET_okINTEGER3 + ffetargetInteger3 integer3; +#endif +#if FFETARGET_okINTEGER4 + ffetargetInteger4 integer4; +#endif +#if FFETARGET_okINTEGER5 + ffetargetInteger5 integer5; +#endif +#if FFETARGET_okINTEGER6 + ffetargetInteger6 integer6; +#endif +#if FFETARGET_okINTEGER7 + ffetargetInteger7 integer7; +#endif +#if FFETARGET_okINTEGER8 + ffetargetInteger8 integer8; +#endif +#if FFETARGET_okLOGICAL1 + ffetargetLogical1 logical1; +#endif +#if FFETARGET_okLOGICAL2 + ffetargetLogical2 logical2; +#endif +#if FFETARGET_okLOGICAL3 + ffetargetLogical3 logical3; +#endif +#if FFETARGET_okLOGICAL4 + ffetargetLogical4 logical4; +#endif +#if FFETARGET_okLOGICAL5 + ffetargetLogical5 logical5; +#endif +#if FFETARGET_okLOGICAL6 + ffetargetLogical6 logical6; +#endif +#if FFETARGET_okLOGICAL7 + ffetargetLogical7 logical7; +#endif +#if FFETARGET_okLOGICAL8 + ffetargetLogical8 logical8; +#endif +#if FFETARGET_okREAL1 + ffetargetReal1 real1; +#endif +#if FFETARGET_okREAL2 + ffetargetReal2 real2; +#endif +#if FFETARGET_okREAL3 + ffetargetReal3 real3; +#endif +#if FFETARGET_okREAL4 + ffetargetReal4 real4; +#endif +#if FFETARGET_okREAL5 + ffetargetReal5 real5; +#endif +#if FFETARGET_okREAL6 + ffetargetReal6 real6; +#endif +#if FFETARGET_okREAL7 + ffetargetReal7 real7; +#endif +#if FFETARGET_okREAL8 + ffetargetReal8 real8; +#endif +#if FFETARGET_okCOMPLEX1 + ffetargetComplex1 complex1; +#endif +#if FFETARGET_okCOMPLEX2 + ffetargetComplex2 complex2; +#endif +#if FFETARGET_okCOMPLEX3 + ffetargetComplex3 complex3; +#endif +#if FFETARGET_okCOMPLEX4 + ffetargetComplex4 complex4; +#endif +#if FFETARGET_okCOMPLEX5 + ffetargetComplex5 complex5; +#endif +#if FFETARGET_okCOMPLEX6 + ffetargetComplex6 complex6; +#endif +#if FFETARGET_okCOMPLEX7 + ffetargetComplex7 complex7; +#endif +#if FFETARGET_okCOMPLEX8 + ffetargetComplex8 complex8; +#endif +#if FFETARGET_okCHARACTER1 + ffetargetCharacter1 character1; +#endif +#if FFETARGET_okCHARACTER2 + ffetargetCharacter2 character2; +#endif +#if FFETARGET_okCHARACTER3 + ffetargetCharacter3 character3; +#endif +#if FFETARGET_okCHARACTER4 + ffetargetCharacter4 character4; +#endif +#if FFETARGET_okCHARACTER5 + ffetargetCharacter5 character5; +#endif +#if FFETARGET_okCHARACTER6 + ffetargetCharacter6 character6; +#endif +#if FFETARGET_okCHARACTER7 + ffetargetCharacter7 character7; +#endif +#if FFETARGET_okCHARACTER8 + ffetargetCharacter8 character8; +#endif + }; + +union _ffebld_constant_array_ + { +#if FFETARGET_okINTEGER1 + ffetargetInteger1 *integer1; +#endif +#if FFETARGET_okINTEGER2 + ffetargetInteger2 *integer2; +#endif +#if FFETARGET_okINTEGER3 + ffetargetInteger3 *integer3; +#endif +#if FFETARGET_okINTEGER4 + ffetargetInteger4 *integer4; +#endif +#if FFETARGET_okINTEGER5 + ffetargetInteger5 *integer5; +#endif +#if FFETARGET_okINTEGER6 + ffetargetInteger6 *integer6; +#endif +#if FFETARGET_okINTEGER7 + ffetargetInteger7 *integer7; +#endif +#if FFETARGET_okINTEGER8 + ffetargetInteger8 *integer8; +#endif +#if FFETARGET_okLOGICAL1 + ffetargetLogical1 *logical1; +#endif +#if FFETARGET_okLOGICAL2 + ffetargetLogical2 *logical2; +#endif +#if FFETARGET_okLOGICAL3 + ffetargetLogical3 *logical3; +#endif +#if FFETARGET_okLOGICAL4 + ffetargetLogical4 *logical4; +#endif +#if FFETARGET_okLOGICAL5 + ffetargetLogical5 *logical5; +#endif +#if FFETARGET_okLOGICAL6 + ffetargetLogical6 *logical6; +#endif +#if FFETARGET_okLOGICAL7 + ffetargetLogical7 *logical7; +#endif +#if FFETARGET_okLOGICAL8 + ffetargetLogical8 *logical8; +#endif +#if FFETARGET_okREAL1 + ffetargetReal1 *real1; +#endif +#if FFETARGET_okREAL2 + ffetargetReal2 *real2; +#endif +#if FFETARGET_okREAL3 + ffetargetReal3 *real3; +#endif +#if FFETARGET_okREAL4 + ffetargetReal4 *real4; +#endif +#if FFETARGET_okREAL5 + ffetargetReal5 *real5; +#endif +#if FFETARGET_okREAL6 + ffetargetReal6 *real6; +#endif +#if FFETARGET_okREAL7 + ffetargetReal7 *real7; +#endif +#if FFETARGET_okREAL8 + ffetargetReal8 *real8; +#endif +#if FFETARGET_okCOMPLEX1 + ffetargetComplex1 *complex1; +#endif +#if FFETARGET_okCOMPLEX2 + ffetargetComplex2 *complex2; +#endif +#if FFETARGET_okCOMPLEX3 + ffetargetComplex3 *complex3; +#endif +#if FFETARGET_okCOMPLEX4 + ffetargetComplex4 *complex4; +#endif +#if FFETARGET_okCOMPLEX5 + ffetargetComplex5 *complex5; +#endif +#if FFETARGET_okCOMPLEX6 + ffetargetComplex6 *complex6; +#endif +#if FFETARGET_okCOMPLEX7 + ffetargetComplex7 *complex7; +#endif +#if FFETARGET_okCOMPLEX8 + ffetargetComplex8 *complex8; +#endif +#if FFETARGET_okCHARACTER1 + ffetargetCharacterUnit1 *character1; +#endif +#if FFETARGET_okCHARACTER2 + ffetargetCharacterUnit2 *character2; +#endif +#if FFETARGET_okCHARACTER3 + ffetargetCharacterUnit3 *character3; +#endif +#if FFETARGET_okCHARACTER4 + ffetargetCharacterUnit4 *character4; +#endif +#if FFETARGET_okCHARACTER5 + ffetargetCharacterUnit5 *character5; +#endif +#if FFETARGET_okCHARACTER6 + ffetargetCharacterUnit6 *character6; +#endif +#if FFETARGET_okCHARACTER7 + ffetargetCharacterUnit7 *character7; +#endif +#if FFETARGET_okCHARACTER8 + ffetargetCharacterUnit8 *character8; +#endif + }; + +struct _ffebld_ + { + ffebldOp op; + ffeinfo info; /* Not used or valid for + op=={STAR,ITEM,BOUNDS,REPEAT,LABTER, + LABTOK,IMPDO}. */ + union + { + struct + { + ffebld left; + ffebld right; + } + nonter; + struct + { + ffebld head; + ffebld trail; + } + item; + struct + { + ffebldConstant expr; + ffebld orig; /* Original expression, or NULL if none. */ + } + conter; + struct + { + ffebldConstantArray array; + ffetargetOffset size; + } + arrter; + struct + { + ffebldConstantArray array; + ffebit bits; + } + accter; + struct + { + ffesymbol symbol; + ffeintrinGen generic; /* Id for generic intrinsic. */ + ffeintrinSpec specific; /* Id for specific intrinsic. */ + ffeintrinImp implementation; /* Id for implementation. */ + bool do_iter; /* TRUE if this ref is a read-only ref by + definition (ref within DO loop using this + var as iterator). */ + } + symter; + ffelab labter; + ffelexToken labtok; + } + u; + }; + +struct _ffebld_constant_ + { + ffebldConstant next; + ffebldConstant first_complex; /* First complex const with me as + real. */ + ffebldConstant negated; /* We point to each other through here. */ + ffebldConst consttype; +#ifdef FFECOM_constantHOOK + ffecomConstant hook; /* Whatever the compiler/backend wants! */ +#endif + bool numeric; /* A numeric kind of constant. */ + ffebldConstantUnion u; + }; + +struct _ffebld_pool_stack_ + { + ffebldPoolstack_ next; + mallocPool pool; + }; + +/* Global objects accessed by users of this module. */ + +extern ffebldArity ffebld_arity_op_[]; +extern struct _ffebld_pool_stack_ ffebld_pool_stack_; + +/* Declare functions with prototypes. */ + +int ffebld_constant_cmp (ffebldConstant c1, ffebldConstant c2); +void ffebld_constant_dump (ffebldConstant c); +bool ffebld_constant_is_magical (ffebldConstant c); +bool ffebld_constant_is_zero (ffebldConstant c); +#if FFETARGET_okCHARACTER1 +ffebldConstant ffebld_constant_new_character1 (ffelexToken t); +ffebldConstant ffebld_constant_new_character1_val (ffetargetCharacter1 val); +#endif +#if FFETARGET_okCHARACTER2 +ffebldConstant ffebld_constant_new_character2 (ffelexToken t); +ffebldConstant ffebld_constant_new_character2_val (ffetargetCharacter2 val); +#endif +#if FFETARGET_okCHARACTER3 +ffebldConstant ffebld_constant_new_character3 (ffelexToken t); +ffebldConstant ffebld_constant_new_character3_val (ffetargetCharacter3 val); +#endif +#if FFETARGET_okCHARACTER4 +ffebldConstant ffebld_constant_new_character4 (ffelexToken t); +ffebldConstant ffebld_constant_new_character4_val (ffetargetCharacter4 val); +#endif +#if FFETARGET_okCHARACTER5 +ffebldConstant ffebld_constant_new_character5 (ffelexToken t); +ffebldConstant ffebld_constant_new_character5_val (ffetargetCharacter5 val); +#endif +#if FFETARGET_okCHARACTER6 +ffebldConstant ffebld_constant_new_character6 (ffelexToken t); +ffebldConstant ffebld_constant_new_character6_val (ffetargetCharacter6 val); +#endif +#if FFETARGET_okCHARACTER7 +ffebldConstant ffebld_constant_new_character7 (ffelexToken t); +ffebldConstant ffebld_constant_new_character7_val (ffetargetCharacter7 val); +#endif +#if FFETARGET_okCHARACTER8 +ffebldConstant ffebld_constant_new_character8 (ffelexToken t); +ffebldConstant ffebld_constant_new_character8_val (ffetargetCharacter8 val); +#endif +#if FFETARGET_okCOMPLEX1 +ffebldConstant ffebld_constant_new_complex1 (ffebldConstant real, + ffebldConstant imaginary); +ffebldConstant ffebld_constant_new_complex1_val (ffetargetComplex1 val); +#endif +#if FFETARGET_okCOMPLEX2 +ffebldConstant ffebld_constant_new_complex2 (ffebldConstant real, + ffebldConstant imaginary); +ffebldConstant ffebld_constant_new_complex2_val (ffetargetComplex2 val); +#endif +#if FFETARGET_okCOMPLEX3 +ffebldConstant ffebld_constant_new_complex3 (ffebldConstant real, + ffebldConstant imaginary); +ffebldConstant ffebld_constant_new_complex3_val (ffetargetComplex3 val); +#endif +#if FFETARGET_okCOMPLEX4 +ffebldConstant ffebld_constant_new_complex4 (ffebldConstant real, + ffebldConstant imaginary); +ffebldConstant ffebld_constant_new_complex4_val (ffetargetComplex4 val); +#endif +#if FFETARGET_okCOMPLEX5 +ffebldConstant ffebld_constant_new_complex5 (ffebldConstant real, + ffebldConstant imaginary); +ffebldConstant ffebld_constant_new_complex5_val (ffetargetComplex5 val); +#endif +#if FFETARGET_okCOMPLEX6 +ffebldConstant ffebld_constant_new_complex6 (ffebldConstant real, + ffebldConstant imaginary); +ffebldConstant ffebld_constant_new_complex6_val (ffetargetComplex6 val); +#endif +#if FFETARGET_okCOMPLEX7 +ffebldConstant ffebld_constant_new_complex7 (ffebldConstant real, + ffebldConstant imaginary); +ffebldConstant ffebld_constant_new_complex7_val (ffetargetComplex7 val); +#endif +#if FFETARGET_okCOMPLEX8 +ffebldConstant ffebld_constant_new_complex8 (ffebldConstant real, + ffebldConstant imaginary); +ffebldConstant ffebld_constant_new_complex8_val (ffetargetComplex8 val); +#endif +ffebldConstant ffebld_constant_new_hollerith (ffelexToken t); +ffebldConstant ffebld_constant_new_hollerith_val (ffetargetHollerith val); +#if FFETARGET_okINTEGER1 +ffebldConstant ffebld_constant_new_integer1 (ffelexToken t); +ffebldConstant ffebld_constant_new_integer1_val (ffetargetInteger1 val); +#endif +#if FFETARGET_okINTEGER2 +ffebldConstant ffebld_constant_new_integer2 (ffelexToken t); +ffebldConstant ffebld_constant_new_integer2_val (ffetargetInteger2 val); +#endif +#if FFETARGET_okINTEGER3 +ffebldConstant ffebld_constant_new_integer3 (ffelexToken t); +ffebldConstant ffebld_constant_new_integer3_val (ffetargetInteger3 val); +#endif +#if FFETARGET_okINTEGER4 +ffebldConstant ffebld_constant_new_integer4 (ffelexToken t); +ffebldConstant ffebld_constant_new_integer4_val (ffetargetInteger4 val); +#endif +#if FFETARGET_okINTEGER5 +ffebldConstant ffebld_constant_new_integer5 (ffelexToken t); +ffebldConstant ffebld_constant_new_integer5_val (ffetargetInteger5 val); +#endif +#if FFETARGET_okINTEGER6 +ffebldConstant ffebld_constant_new_integer6 (ffelexToken t); +ffebldConstant ffebld_constant_new_integer6_val (ffetargetInteger6 val); +#endif +#if FFETARGET_okINTEGER7 +ffebldConstant ffebld_constant_new_integer7 (ffelexToken t); +ffebldConstant ffebld_constant_new_integer7_val (ffetargetInteger7 val); +#endif +#if FFETARGET_okINTEGER8 +ffebldConstant ffebld_constant_new_integer8 (ffelexToken t); +ffebldConstant ffebld_constant_new_integer8_val (ffetargetInteger8 val); +#endif +ffebldConstant ffebld_constant_new_integerbinary (ffelexToken t); +ffebldConstant ffebld_constant_new_integerhex (ffelexToken t); +ffebldConstant ffebld_constant_new_integeroctal (ffelexToken t); +#if FFETARGET_okLOGICAL1 +ffebldConstant ffebld_constant_new_logical1 (bool truth); +ffebldConstant ffebld_constant_new_logical1_val (ffetargetLogical1 val); +#endif +#if FFETARGET_okLOGICAL2 +ffebldConstant ffebld_constant_new_logical2 (bool truth); +ffebldConstant ffebld_constant_new_logical2_val (ffetargetLogical2 val); +#endif +#if FFETARGET_okLOGICAL3 +ffebldConstant ffebld_constant_new_logical3 (bool truth); +ffebldConstant ffebld_constant_new_logical3_val (ffetargetLogical3 val); +#endif +#if FFETARGET_okLOGICAL4 +ffebldConstant ffebld_constant_new_logical4 (bool truth); +ffebldConstant ffebld_constant_new_logical4_val (ffetargetLogical4 val); +#endif +#if FFETARGET_okLOGICAL5 +ffebldConstant ffebld_constant_new_logical5 (bool truth); +ffebldConstant ffebld_constant_new_logical5_val (ffetargetLogical5 val); +#endif +#if FFETARGET_okLOGICAL6 +ffebldConstant ffebld_constant_new_logical6 (bool truth); +ffebldConstant ffebld_constant_new_logical6_val (ffetargetLogical6 val); +#endif +#if FFETARGET_okLOGICAL7 +ffebldConstant ffebld_constant_new_logical7 (bool truth); +ffebldConstant ffebld_constant_new_logical7_val (ffetargetLogical7 val); +#endif +#if FFETARGET_okLOGICAL8 +ffebldConstant ffebld_constant_new_logical8 (bool truth); +ffebldConstant ffebld_constant_new_logical8_val (ffetargetLogical8 val); +#endif +#if FFETARGET_okREAL1 +ffebldConstant ffebld_constant_new_real1 (ffelexToken integer, + ffelexToken decimal, ffelexToken fraction, ffelexToken exponent, + ffelexToken exponent_sign, ffelexToken exponent_digits); +ffebldConstant ffebld_constant_new_real1_val (ffetargetReal1 val); +#endif +#if FFETARGET_okREAL2 +ffebldConstant ffebld_constant_new_real2 (ffelexToken integer, + ffelexToken decimal, ffelexToken fraction, ffelexToken exponent, + ffelexToken exponent_sign, ffelexToken exponent_digits); +ffebldConstant ffebld_constant_new_real2_val (ffetargetReal2 val); +#endif +#if FFETARGET_okREAL3 +ffebldConstant ffebld_constant_new_real3 (ffelexToken integer, + ffelexToken decimal, ffelexToken fraction, ffelexToken exponent, + ffelexToken exponent_sign, ffelexToken exponent_digits); +ffebldConstant ffebld_constant_new_real3_val (ffetargetReal3 val); +#endif +#if FFETARGET_okREAL4 +ffebldConstant ffebld_constant_new_real4 (ffelexToken integer, + ffelexToken decimal, ffelexToken fraction, ffelexToken exponent, + ffelexToken exponent_sign, ffelexToken exponent_digits); +ffebldConstant ffebld_constant_new_real4_val (ffetargetReal4 val); +#endif +#if FFETARGET_okREAL5 +ffebldConstant ffebld_constant_new_real5 (ffelexToken integer, + ffelexToken decimal, ffelexToken fraction, ffelexToken exponent, + ffelexToken exponent_sign, ffelexToken exponent_digits); +ffebldConstant ffebld_constant_new_real5_val (ffetargetReal5 val); +#endif +#if FFETARGET_okREAL6 +ffebldConstant ffebld_constant_new_real6 (ffelexToken integer, + ffelexToken decimal, ffelexToken fraction, ffelexToken exponent, + ffelexToken exponent_sign, ffelexToken exponent_digits); +ffebldConstant ffebld_constant_new_real6_val (ffetargetReal6 val); +#endif +#if FFETARGET_okREAL7 +ffebldConstant ffebld_constant_new_real7 (ffelexToken integer, + ffelexToken decimal, ffelexToken fraction, ffelexToken exponent, + ffelexToken exponent_sign, ffelexToken exponent_digits); +ffebldConstant ffebld_constant_new_real7_val (ffetargetReal7 val); +#endif +#if FFETARGET_okREAL8 +ffebldConstant ffebld_constant_new_real8 (ffelexToken integer, + ffelexToken decimal, ffelexToken fraction, ffelexToken exponent, + ffelexToken exponent_sign, ffelexToken exponent_digits); +ffebldConstant ffebld_constant_new_real8_val (ffetargetReal8 val); +#endif +ffebldConstant ffebld_constant_new_typeless_bm (ffelexToken t); +ffebldConstant ffebld_constant_new_typeless_bv (ffelexToken t); +ffebldConstant ffebld_constant_new_typeless_hxm (ffelexToken t); +ffebldConstant ffebld_constant_new_typeless_hxv (ffelexToken t); +ffebldConstant ffebld_constant_new_typeless_hzm (ffelexToken t); +ffebldConstant ffebld_constant_new_typeless_hzv (ffelexToken t); +ffebldConstant ffebld_constant_new_typeless_om (ffelexToken t); +ffebldConstant ffebld_constant_new_typeless_ov (ffelexToken t); +ffebldConstant ffebld_constant_new_typeless_val (ffebldConst type, + ffetargetTypeless val); +ffebldConstant ffebld_constant_negated (ffebldConstant c); +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); +void ffebld_constantarray_kill (ffebldConstantArray array, ffeinfoBasictype bt, + ffeinfoKindtype kt, ffetargetOffset size); +ffebldConstantArray ffebld_constantarray_new (ffeinfoBasictype bt, + ffeinfoKindtype kt, ffetargetOffset size); +void ffebld_constantarray_prepare (void **aptr, void **cptr, size_t *size, + ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt, + ffetargetOffset offset, ffebldConstantUnion *constant, + ffeinfoBasictype cbt, ffeinfoKindtype ckt); +void ffebld_constantarray_preparray (void **aptr, void **cptr, size_t *size, + ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt, + ffetargetOffset offset, ffebldConstantArray source_array, + ffeinfoBasictype cbt, ffeinfoKindtype ckt); +void ffebld_constantarray_put (ffebldConstantArray array, ffeinfoBasictype bt, + ffeinfoKindtype kt, ffetargetOffset offset, ffebldConstantUnion constant); +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); +void ffebld_init_0 (void); +void ffebld_init_1 (void); +void ffebld_init_2 (void); +ffebldListLength ffebld_list_length (ffebld l); +ffebld ffebld_new_accter (ffebldConstantArray array, ffebit b); +ffebld ffebld_new_arrter (ffebldConstantArray array, ffetargetOffset size); +ffebld ffebld_new_conter_with_orig (ffebldConstant c, ffebld orig); +ffebld ffebld_new_item (ffebld head, ffebld trail); +ffebld ffebld_new_labter (ffelab l); +ffebld ffebld_new_labtok (ffelexToken t); +ffebld ffebld_new_none (ffebldOp o); +ffebld ffebld_new_symter (ffesymbol s, ffeintrinGen gen, ffeintrinSpec spec, + ffeintrinImp imp); +ffebld ffebld_new_one (ffebldOp o, ffebld left); +ffebld ffebld_new_two (ffebldOp o, ffebld left, ffebld right); +char *ffebld_op_string (ffebldOp o); +void ffebld_pool_pop (void); +void ffebld_pool_push (mallocPool pool); +ffetargetCharacterSize ffebld_size_max (ffebld b); + +/* Define macros. */ + +#define ffebld_accter(b) ((b)->u.accter.array) +#define ffebld_accter_bits(b) ((b)->u.accter.bits) +#define ffebld_accter_set_bits(b,bt) ((b)->u.accter.bits = (bt)) +#define ffebld_accter_size(b) ffebit_size((b)->u.accter.bits) +#define ffebld_append_item(b,i) (**(b) = ffebld_new_item((i),NULL), \ + *(b) = &((**(b))->u.item.trail)) +#define ffebld_arity(b) ffebld_arity_op(ffebld_op(b)) +#define ffebld_arity_op(o) (ffebld_arity_op_[o]) +#define ffebld_arrter(b) ((b)->u.arrter.array) +#define ffebld_arrter_set_size(b,s) ((b)->u.arrter.size = (s)) +#define ffebld_arrter_size(b) ((b)->u.arrter.size) +#if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_ +#define ffebld_constant_pool() ffe_pool_program_unit() +#elif FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstFILE_ +#define ffebld_constant_pool() ffe_pool_file() +#else +#error +#endif +#define ffebld_constant_character1(c) ((c)->u.character1) +#define ffebld_constant_character2(c) ((c)->u.character2) +#define ffebld_constant_character3(c) ((c)->u.character3) +#define ffebld_constant_character4(c) ((c)->u.character4) +#define ffebld_constant_character5(c) ((c)->u.character5) +#define ffebld_constant_character6(c) ((c)->u.character6) +#define ffebld_constant_character7(c) ((c)->u.character7) +#define ffebld_constant_character8(c) ((c)->u.character8) +#define ffebld_constant_characterdefault ffebld_constant_character1 +#define ffebld_constant_complex1(c) ((c)->u.complex1) +#define ffebld_constant_complex2(c) ((c)->u.complex2) +#define ffebld_constant_complex3(c) ((c)->u.complex3) +#define ffebld_constant_complex4(c) ((c)->u.complex4) +#define ffebld_constant_complex5(c) ((c)->u.complex5) +#define ffebld_constant_complex6(c) ((c)->u.complex6) +#define ffebld_constant_complex7(c) ((c)->u.complex7) +#define ffebld_constant_complex8(c) ((c)->u.complex8) +#define ffebld_constant_complexdefault ffebld_constant_complex1 +#define ffebld_constant_complexdouble ffebld_constant_complex2 +#define ffebld_constant_complexquad ffebld_constant_complex3 +#define ffebld_constant_copy(c) (c) +#define ffebld_constant_hollerith(c) ((c)->u.hollerith) +#define ffebld_constant_hook(c) ((c)->hook) +#define ffebld_constant_integer1(c) ((c)->u.integer1) +#define ffebld_constant_integer2(c) ((c)->u.integer2) +#define ffebld_constant_integer3(c) ((c)->u.integer3) +#define ffebld_constant_integer4(c) ((c)->u.integer4) +#define ffebld_constant_integer5(c) ((c)->u.integer5) +#define ffebld_constant_integer6(c) ((c)->u.integer6) +#define ffebld_constant_integer7(c) ((c)->u.integer7) +#define ffebld_constant_integer8(c) ((c)->u.integer8) +#define ffebld_constant_integerdefault ffebld_constant_integer1 +#define ffebld_constant_is_numeric(c) ((c)->numeric) +#define ffebld_constant_logical1(c) ((c)->u.logical1) +#define ffebld_constant_logical2(c) ((c)->u.logical2) +#define ffebld_constant_logical3(c) ((c)->u.logical3) +#define ffebld_constant_logical4(c) ((c)->u.logical4) +#define ffebld_constant_logical5(c) ((c)->u.logical5) +#define ffebld_constant_logical6(c) ((c)->u.logical6) +#define ffebld_constant_logical7(c) ((c)->u.logical7) +#define ffebld_constant_logical8(c) ((c)->u.logical8) +#define ffebld_constant_logicaldefault ffebld_constant_logical1 +#define ffebld_constant_new_characterdefault ffebld_constant_new_character1 +#define ffebld_constant_new_characterdefault_val ffebld_constant_new_character1_val +#define ffebld_constant_new_complexdefault ffebld_constant_new_complex1 +#define ffebld_constant_new_complexdefault_val ffebld_constant_new_complex1_val +#define ffebld_constant_new_complexdouble ffebld_constant_new_complex2 +#define ffebld_constant_new_complexdouble_val ffebld_constant_new_complex2_val +#define ffebld_constant_new_complexquad ffebld_constant_new_complex3 +#define ffebld_constant_new_complexquad_valffebld_constant_new_complex3_val +#define ffebld_constant_new_integerdefault ffebld_constant_new_integer1 +#define ffebld_constant_new_integerdefault_val ffebld_constant_new_integer1_val +#define ffebld_constant_new_logicaldefault ffebld_constant_new_logical1 +#define ffebld_constant_new_logicaldefault_val ffebld_constant_new_logical1_val +#define ffebld_constant_new_realdefault ffebld_constant_new_real1 +#define ffebld_constant_new_realdefault_val ffebld_constant_new_real1_val +#define ffebld_constant_new_realdouble ffebld_constant_new_real2 +#define ffebld_constant_new_realdouble_val ffebld_constant_new_real2_val +#define ffebld_constant_new_realquad ffebld_constant_new_real3 +#define ffebld_constant_new_realquad_val ffebld_constant_new_real3_val +#define ffebld_constant_ptr_to_union(c) (&(c)->u) +#define ffebld_constant_real1(c) ((c)->u.real1) +#define ffebld_constant_real2(c) ((c)->u.real2) +#define ffebld_constant_real3(c) ((c)->u.real3) +#define ffebld_constant_real4(c) ((c)->u.real4) +#define ffebld_constant_real5(c) ((c)->u.real5) +#define ffebld_constant_real6(c) ((c)->u.real6) +#define ffebld_constant_real7(c) ((c)->u.real7) +#define ffebld_constant_real8(c) ((c)->u.real8) +#define ffebld_constant_realdefault ffebld_constant_real1 +#define ffebld_constant_realdouble ffebld_constant_real2 +#define ffebld_constant_realquad ffebld_constant_real3 +#define ffebld_constant_set_hook(c,h) ((c)->hook = (h)) +#define ffebld_constant_set_union(c,un) ((c)->u = (un)) +#define ffebld_constant_type(c) ((c)->consttype) +#define ffebld_constant_typeless(c) ((c)->u.typeless) +#define ffebld_constant_union(c) ((c)->u) +#define ffebld_conter(b) ((b)->u.conter.expr) +#define ffebld_conter_orig(b) ((b)->u.conter.orig) +#define ffebld_conter_set_orig(b,o) ((b)->u.conter.orig = (o)) +#define ffebld_copy(b) (b) /* ~~~Someday really make a copy. */ +#define ffebld_cu_ptr_typeless(u) &(u).typeless +#define ffebld_cu_ptr_hollerith(u) &(u).hollerith +#define ffebld_cu_ptr_integer1(u) &(u).integer1 +#define ffebld_cu_ptr_integer2(u) &(u).integer2 +#define ffebld_cu_ptr_integer3(u) &(u).integer3 +#define ffebld_cu_ptr_integer4(u) &(u).integer4 +#define ffebld_cu_ptr_integer5(u) &(u).integer5 +#define ffebld_cu_ptr_integer6(u) &(u).integer6 +#define ffebld_cu_ptr_integer7(u) &(u).integer7 +#define ffebld_cu_ptr_integer8(u) &(u).integer8 +#define ffebld_cu_ptr_integerdefault ffebld_cu_ptr_integer1 +#define ffebld_cu_ptr_logical1(u) &(u).logical1 +#define ffebld_cu_ptr_logical2(u) &(u).logical2 +#define ffebld_cu_ptr_logical3(u) &(u).logical3 +#define ffebld_cu_ptr_logical4(u) &(u).logical4 +#define ffebld_cu_ptr_logical5(u) &(u).logical5 +#define ffebld_cu_ptr_logical6(u) &(u).logical6 +#define ffebld_cu_ptr_logical7(u) &(u).logical7 +#define ffebld_cu_ptr_logical8(u) &(u).logical8 +#define ffebld_cu_ptr_logicaldefault ffebld_cu_ptr_logical1 +#define ffebld_cu_ptr_real1(u) &(u).real1 +#define ffebld_cu_ptr_real2(u) &(u).real2 +#define ffebld_cu_ptr_real3(u) &(u).real3 +#define ffebld_cu_ptr_real4(u) &(u).real4 +#define ffebld_cu_ptr_real5(u) &(u).real5 +#define ffebld_cu_ptr_real6(u) &(u).real6 +#define ffebld_cu_ptr_real7(u) &(u).real7 +#define ffebld_cu_ptr_real8(u) &(u).real8 +#define ffebld_cu_ptr_realdefault ffebld_cu_ptr_real1 +#define ffebld_cu_ptr_realdouble ffebld_cu_ptr_real2 +#define ffebld_cu_ptr_realquad ffebld_cu_ptr_real3 +#define ffebld_cu_ptr_complex1(u) &(u).complex1 +#define ffebld_cu_ptr_complex2(u) &(u).complex2 +#define ffebld_cu_ptr_complex3(u) &(u).complex3 +#define ffebld_cu_ptr_complex4(u) &(u).complex4 +#define ffebld_cu_ptr_complex5(u) &(u).complex5 +#define ffebld_cu_ptr_complex6(u) &(u).complex6 +#define ffebld_cu_ptr_complex7(u) &(u).complex7 +#define ffebld_cu_ptr_complex8(u) &(u).complex8 +#define ffebld_cu_ptr_complexdefault ffebld_cu_ptr_complex1 +#define ffebld_cu_ptr_complexdouble ffebld_cu_ptr_complex2 +#define ffebld_cu_ptr_complexquad ffebld_cu_ptr_complex3 +#define ffebld_cu_ptr_character1(u) &(u).character1 +#define ffebld_cu_ptr_character2(u) &(u).character2 +#define ffebld_cu_ptr_character3(u) &(u).character3 +#define ffebld_cu_ptr_character4(u) &(u).character4 +#define ffebld_cu_ptr_character5(u) &(u).character5 +#define ffebld_cu_ptr_character6(u) &(u).character6 +#define ffebld_cu_ptr_character7(u) &(u).character7 +#define ffebld_cu_ptr_character8(u) &(u).character8 +#define ffebld_cu_val_typeless(u) (u).typeless +#define ffebld_cu_val_hollerith(u) (u).hollerith +#define ffebld_cu_val_integer1(u) (u).integer1 +#define ffebld_cu_val_integer2(u) (u).integer2 +#define ffebld_cu_val_integer3(u) (u).integer3 +#define ffebld_cu_val_integer4(u) (u).integer4 +#define ffebld_cu_val_integer5(u) (u).integer5 +#define ffebld_cu_val_integer6(u) (u).integer6 +#define ffebld_cu_val_integer7(u) (u).integer7 +#define ffebld_cu_val_integer8(u) (u).integer8 +#define ffebld_cu_val_integerdefault ffebld_cu_val_integer1 +#define ffebld_cu_val_logical1(u) (u).logical1 +#define ffebld_cu_val_logical2(u) (u).logical2 +#define ffebld_cu_val_logical3(u) (u).logical3 +#define ffebld_cu_val_logical4(u) (u).logical4 +#define ffebld_cu_val_logical5(u) (u).logical5 +#define ffebld_cu_val_logical6(u) (u).logical6 +#define ffebld_cu_val_logical7(u) (u).logical7 +#define ffebld_cu_val_logical8(u) (u).logical8 +#define ffebld_cu_val_logicaldefault ffebld_cu_val_logical +#define ffebld_cu_val_real1(u) (u).real1 +#define ffebld_cu_val_real2(u) (u).real2 +#define ffebld_cu_val_real3(u) (u).real3 +#define ffebld_cu_val_real4(u) (u).real4 +#define ffebld_cu_val_real5(u) (u).real5 +#define ffebld_cu_val_real6(u) (u).real6 +#define ffebld_cu_val_real7(u) (u).real7 +#define ffebld_cu_val_real8(u) (u).real8 +#define ffebld_cu_val_realdefault ffebld_cu_val_real1 +#define ffebld_cu_val_realdouble ffebld_cu_val_real2 +#define ffebld_cu_val_realquad ffebld_cu_val_real3 +#define ffebld_cu_val_complex1(u) (u).complex1 +#define ffebld_cu_val_complex2(u) (u).complex2 +#define ffebld_cu_val_complex3(u) (u).complex3 +#define ffebld_cu_val_complex4(u) (u).complex4 +#define ffebld_cu_val_complex5(u) (u).complex5 +#define ffebld_cu_val_complex6(u) (u).complex6 +#define ffebld_cu_val_complex7(u) (u).complex7 +#define ffebld_cu_val_complex8(u) (u).complex8 +#define ffebld_cu_val_complexdefault ffebld_cu_val_complex1 +#define ffebld_cu_val_complexdouble ffebld_cu_val_complex2 +#define ffebld_cu_val_complexquad ffebld_cu_val_complex3 +#define ffebld_cu_val_character1(u) (u).character1 +#define ffebld_cu_val_character2(u) (u).character2 +#define ffebld_cu_val_character3(u) (u).character3 +#define ffebld_cu_val_character4(u) (u).character4 +#define ffebld_cu_val_character5(u) (u).character5 +#define ffebld_cu_val_character6(u) (u).character6 +#define ffebld_cu_val_character7(u) (u).character7 +#define ffebld_cu_val_character8(u) (u).character8 +#define ffebld_end_list(b) (*(b) = NULL) +#define ffebld_head(b) ((b)->u.item.head) +#define ffebld_info(b) ((b)->info) +#define ffebld_init_3() +#define ffebld_init_4() +#define ffebld_init_list(l,b) (*(l) = NULL, *(b) = (l)) +#define ffebld_labter(b) ((b)->u.labter) +#define ffebld_labtok(b) ((b)->u.labtok) +#define ffebld_left(b) ((b)->u.nonter.left) +#define ffebld_name_string(n) ((n)->name) +#define ffebld_new() \ + ((ffebld) malloc_new_kp(ffebld_pool(), "FFEBLD",sizeof(struct _ffebld_))) +#define ffebld_new_any() ffebld_new_none(FFEBLD_opANY) +#define ffebld_new_conter(c) ffebld_new_conter_with_orig((c),NULL) +#define ffebld_new_star() ffebld_new_none(FFEBLD_opSTAR) +#define ffebld_new_uplus(l) ffebld_new_one(FFEBLD_opUPLUS,(l)) +#define ffebld_new_uminus(l) ffebld_new_one(FFEBLD_opUMINUS,(l)) +#define ffebld_new_add(l,r) ffebld_new_two(FFEBLD_opADD,(l),(r)) +#define ffebld_new_subtract(l,r) ffebld_new_two(FFEBLD_opSUBTRACT,(l),(r)) +#define ffebld_new_multiply(l,r) ffebld_new_two(FFEBLD_opMULTIPLY,(l),(r)) +#define ffebld_new_divide(l,r) ffebld_new_two(FFEBLD_opDIVIDE,(l),(r)) +#define ffebld_new_power(l,r) ffebld_new_two(FFEBLD_opPOWER,(l),(r)) +#define ffebld_new_bounds(l,r) ffebld_new_two(FFEBLD_opBOUNDS,(l),(r)) +#define ffebld_new_concatenate(l,r) ffebld_new_two(FFEBLD_opCONCATENATE,(l),(r)) +#define ffebld_new_not(l) ffebld_new_one(FFEBLD_opNOT,(l)) +#define ffebld_new_lt(l,r) ffebld_new_two(FFEBLD_opLT,(l),(r)) +#define ffebld_new_le(l,r) ffebld_new_two(FFEBLD_opLE,(l),(r)) +#define ffebld_new_eq(l,r) ffebld_new_two(FFEBLD_opEQ,(l),(r)) +#define ffebld_new_ne(l,r) ffebld_new_two(FFEBLD_opNE,(l),(r)) +#define ffebld_new_gt(l,r) ffebld_new_two(FFEBLD_opGT,(l),(r)) +#define ffebld_new_ge(l,r) ffebld_new_two(FFEBLD_opGE,(l),(r)) +#define ffebld_new_and(l,r) ffebld_new_two(FFEBLD_opAND,(l),(r)) +#define ffebld_new_or(l,r) ffebld_new_two(FFEBLD_opOR,(l),(r)) +#define ffebld_new_xor(l,r) ffebld_new_two(FFEBLD_opXOR,(l),(r)) +#define ffebld_new_eqv(l,r) ffebld_new_two(FFEBLD_opEQV,(l),(r)) +#define ffebld_new_neqv(l,r) ffebld_new_two(FFEBLD_opNEQV,(l),(r)) +#define ffebld_new_paren(l) ffebld_new_one(FFEBLD_opPAREN,(l)) +#define ffebld_new_repeat(l,r) ffebld_new_two(FFEBLD_opREPEAT,(l),(r)) +#define ffebld_new_percent_descr(l) ffebld_new_one(FFEBLD_opPERCENT_DESCR,(l)) +#define ffebld_new_percent_loc(l) ffebld_new_one(FFEBLD_opPERCENT_LOC,(l)) +#define ffebld_new_percent_ref(l) ffebld_new_one(FFEBLD_opPERCENT_REF,(l)) +#define ffebld_new_percent_val(l) ffebld_new_one(FFEBLD_opPERCENT_VAL,(l)) +#define ffebld_new_complex(l,r) ffebld_new_two(FFEBLD_opCOMPLEX,(l),(r)) +#define ffebld_new_convert(l) ffebld_new_one(FFEBLD_opCONVERT,(l)) +#define ffebld_new_funcref(l,r) ffebld_new_two(FFEBLD_opFUNCREF,(l),(r)) +#define ffebld_new_subrref(l,r) ffebld_new_two(FFEBLD_opSUBRREF,(l),(r)) +#define ffebld_new_arrayref(l,r) ffebld_new_two(FFEBLD_opARRAYREF,(l),(r)) +#define ffebld_new_substr(l,r) ffebld_new_two(FFEBLD_opSUBSTR,(l),(r)) +#define ffebld_new_impdo(l,r) ffebld_new_two(FFEBLD_opIMPDO,(l),(r)) +#define ffebld_op(b) ((b)->op) +#define ffebld_pool() (ffebld_pool_stack_.pool) +#define ffebld_right(b) ((b)->u.nonter.right) +#define ffebld_set_accter(b,a) ((b)->u.accter.array = (a)) +#define ffebld_set_arrter(b,a) ((b)->u.arrter.array = (a)) +#define ffebld_set_conter(b,c) ((b)->u.conter.expr = (c)) +#define ffebld_set_info(b,i) ((b)->info = (i)) +#define ffebld_set_labter(b,l) ((b)->u.labter = (l)) +#define ffebld_set_op(b,o) ((b)->op = (o)) +#define ffebld_set_head(b,h) ((b)->u.item.head = (h)) +#define ffebld_set_left(b,l) ((b)->u.nonter.left = (l)) +#define ffebld_set_right(b,r) ((b)->u.nonter.right = (r)) +#define ffebld_set_trail(b,t) ((b)->u.item.trail = (t)) +#define ffebld_size(b) (ffeinfo_size((b)->info)) +#define ffebld_size_known(b) ffebld_size(b) +#define ffebld_symter(b) ((b)->u.symter.symbol) +#define ffebld_symter_generic(b) ((b)->u.symter.generic) +#define ffebld_symter_doiter(b) ((b)->u.symter.do_iter) +#define ffebld_symter_implementation(b) ((b)->u.symter.implementation) +#define ffebld_symter_specific(b) ((b)->u.symter.specific) +#define ffebld_symter_set_generic(b,g) ((b)->u.symter.generic = (g)) +#define ffebld_symter_set_implementation(b,i) \ + ((b)->u.symter.implementation = (i)) +#define ffebld_symter_set_is_doiter(b,f) ((b)->u.symter.do_iter = (f)) +#define ffebld_symter_set_specific(b,s) ((b)->u.symter.specific = (s)) +#define ffebld_terminate_0() +#define ffebld_terminate_1() +#define ffebld_terminate_2() +#define ffebld_terminate_3() +#define ffebld_terminate_4() +#define ffebld_trail(b) ((b)->u.item.trail) + +/* End of #include file. */ + +#endif diff --git a/gcc/f/bugs.texi b/gcc/f/bugs.texi new file mode 100644 index 000000000000..692e1b3a12ff --- /dev/null +++ b/gcc/f/bugs.texi @@ -0,0 +1,287 @@ +@c Copyright (C) 1995-1997 Free Software Foundation, Inc. +@c This is part of the G77 manual. +@c For copying conditions, see the file g77.texi. + +@c The text of this file appears in the file BUGS +@c in the G77 distribution, as well as in the G77 manual. + +@c 1996-06-24 + +@ifclear BUGSONLY +@node Actual Bugs +@section Actual Bugs We Haven't Fixed Yet +@end ifclear + +This section identifies bugs that @code{g77} @emph{users} +might run into. +This includes bugs that are actually in the @code{gcc} +back end (GBE) or in @code{libf2c}, because those +sets of code are at least somewhat under the control +of (and necessarily intertwined with) @code{g77}, so it +isn't worth separating them out. + +For information on bugs that might afflict people who +configure, port, build, and install @code{g77}, +@ref{Problems Installing}. + +@itemize @bullet +@cindex SIGNAL() intrinsic +@cindex intrinsics, SIGNAL() +@item +Work is needed on the @code{SIGNAL()} intrinsic to ensure +that pointers and integers are properly handled on all +targets, including 64-bit machines. + +@cindex -fugly-comma option +@cindex options, -fugly-comma +@item +When using @samp{-fugly-comma}, @code{g77} assumes an extra +@samp{%VAL(0)} argument is to be passed to intrinsics +taking no arguments, such as @code{IARGC()}, which in +turn reject such a call. +Although this has been worked around for 0.5.18 due +to changes in the handling of intrinsics, +@code{g77} needs to do the ugly-argument-appending trick +only for external-function invocation, as this would +probably be more consistent with compilers that default +to using that trick. + +@item +Something about @code{g77}'s straightforward handling of +label references and definitions sometimes prevents the GBE +from unrolling loops. +Until this is solved, try inserting or removing @code{CONTINUE} +statements as the terminal statement, using the @code{END DO} +form instead, and so on. +(Probably improved, but not wholly fixed, in 0.5.21.) + +@item +The @code{g77} command itself should more faithfully process +options the way the @code{gcc} command does. +For example, @code{gcc} accepts abbreviated forms of long options, +@code{g77} generally doesn't. + +@item +Some confusion in diagnostics concerning failing @code{INCLUDE} +statements from within @code{INCLUDE}'d or @code{#include}'d files. + +@cindex integer constants +@cindex constants, integer +@item +@code{g77} assumes that @code{INTEGER(KIND=1)} constants range +from @samp{-2**31} to @samp{2**31-1} (the range for +two's-complement 32-bit values), +instead of determining their range from the actual range of the +type for the configuration (and, someday, for the constant). + +Further, it generally doesn't implement the handling +of constants very well in that it makes assumptions about the +configuration that it no longer makes regarding variables (types). + +Included with this item is the fact that @code{g77} doesn't recognize +that, on IEEE-754/854-compliant systems, @samp{0./0.} should produce a NaN +and no warning instead of the value @samp{0.} and a warning. +This is to be fixed in version 0.6, when @code{g77} will use the +@code{gcc} back end's constant-handling mechanisms to replace its own. + +@cindex compiler speed +@cindex speed, of compiler +@cindex compiler memory usage +@cindex memory usage, of compiler +@cindex large aggregate areas +@cindex initialization +@cindex DATA statement +@cindex statements, DATA +@item +@code{g77} uses way too much memory and CPU time to process large aggregate +areas having any initialized elements. + +For example, @samp{REAL A(1000000)} followed by @samp{DATA A(1)/1/} +takes up way too much time and space, including +the size of the generated assembler file. +This is to be mitigated somewhat in version 0.6. + +Version 0.5.18 improves cases like this---specifically, +cases of @emph{sparse} initialization that leave large, contiguous +areas uninitialized---significantly. +However, even with the improvements, these cases still +require too much memory and CPU time. + +(Version 0.5.18 also improves cases where the initial values are +zero to a much greater degree, so if the above example +ends with @samp{DATA A(1)/0/}, the compile-time performance +will be about as good as it will ever get, aside from unrelated +improvements to the compiler.) + +Note that @code{g77} does display a warning message to +notify the user before the compiler appears to hang. +@xref{Large Initialization,,Initialization of Large Aggregate Areas}, +for information on how to change the point at which +@code{g77} decides to issue this warning. + +@cindex debugging +@cindex common blocks +@cindex equivalence areas +@cindex local equivalence areas +@item +@code{g77} doesn't emit variable and array members of common blocks for use +with a debugger (the @samp{-g} command-line option). +The code is present to do this, but doesn't work with at least +one debug format---perhaps it works with others. +And it turns out there's a similar bug for +local equivalence areas, so that has been disabled as well. + +As of Version 0.5.19, a temporary kludge solution is provided whereby +some rudimentary information on a member is written as a string that +is the member's value as a character string. + +@xref{Code Gen Options,,Options for Code Generation Conventions}, +for information on the @samp{-fdebug-kludge} option. + +@cindex code, displaying main source +@cindex displaying main source code +@cindex debugging main source code +@cindex printing main source +@item +When debugging, after starting up the debugger but before being able +to see the source code for the main program unit, the user must currently +set a breakpoint at @samp{MAIN__} (or @samp{MAIN___} or @samp{MAIN_} if +@samp{MAIN__} doesn't exist) +and run the program until it hits the breakpoint. +At that point, the +main program unit is activated and about to execute its first +executable statement, but that's the state in which the debugger should +start up, as is the case for languages like C. + +@cindex debugger +@item +Debugging @code{g77}-compiled code using debuggers other than +@code{gdb} is likely not to work. + +Getting @code{g77} and @code{gdb} to work together is a known +problem---getting @code{g77} to work properly with other +debuggers, for which source code often is unavailable to @code{g77} +developers, seems like a much larger, unknown problem, +and is a lower priority than making @code{g77} and @code{gdb} +work together properly. + +On the other hand, information about problems other debuggers +have with @code{g77} output might make it easier to properly +fix @code{g77}, and perhaps even improve @code{gdb}, so it +is definitely welcome. +Such information might even lead to all relevant products +working together properly sooner. + +@cindex padding +@cindex structures +@cindex common blocks +@cindex equivalence areas +@item +@code{g77} currently inserts needless padding for things like +@samp{COMMON A,IPAD} where @samp{A} is @code{CHARACTER*1} and @samp{IPAD} +is @code{INTEGER(KIND=1)} on machines like x86, because +the back end insists that @samp{IPAD} be aligned to a 4-byte boundary, but +the processor has no such requirement (though it's good for +performance). + +It is possible that this is not a real bug, and could be considered +a performance feature, but it might be important to provide +the ability to Fortran code to specify minimum padding for +aggregate areas such as common blocks---and, certainly, there +is the potential, with the current setup, for interface differences +in the way such areas are laid out between @code{g77} and other +compilers. + +@item +Some crashes occur when compiling under Solaris on x86 +machines. + +Nothing has been heard about any such problems for some time, +so this is considering a closed item as of 0.5.20. +Please submit any bug reports pertinent to @code{g77}'s support +for Solaris/x86 systems. + +@cindex RS/6000 support +@cindex support, RS/6000 +@item +RS/6000 support is not complete as of the gcc 2.6.3 back end. +The 2.7.0 back end appears to fix this problem, or at least mitigate +it significantly, but there is at least one known problem that is +likely to be a code-generation bug in @file{gcc-2.7.0} plus +@file{g77-0.5.16}. +This problem shows up only when compiling the Fortran program with @samp{-O}. + +Nothing has been heard about any RS/6000 problems for some time, +so this is considering a closed item as of 0.5.20. +Please submit any bug reports pertinent to @code{g77}'s support +for RS/6000 systems. + +@cindex SGI support +@cindex support, SGI +@item +SGI support is known to be a bit buggy. +The known problem shows up only when compiling the Fortran program with +@samp{-O}. + +It is possible these problems have all been fixed in 0.5.20 by +emulating complex arithmetic in the front end. +Please submit any bug reports pertinent to @code{g77}'s support +for SGI systems. + +@cindex Alpha, support +@cindex support, Alpha +@item +@code{g77} doesn't work perfectly on 64-bit configurations such as the Alpha. +This problem is expected to be largely resolved as of version 0.5.20, +and further addressed by 0.5.21. +Version 0.6 should solve most or all related problems (such as +64-bit machines other than Digital Semiconductor (``DEC'') Alphas). + +One known bug that causes a compile-time crash occurs when compiling +code such as the following with optimization: + +@example +SUBROUTINE CRASH (TEMP) +INTEGER*2 HALF(2) +REAL TEMP +HALF(1) = NINT (TEMP) +END +@end example + +It is expected that a future version of @code{g77} will have a fix for this +problem, almost certainly by the time @code{g77} supports the forthcoming +version 2.8.0 of @code{gcc}. + +@cindex COMPLEX support +@cindex support, COMPLEX +@item +Maintainers of gcc report that the back end definitely has ``broken'' +support for @code{COMPLEX} types. +Based on their input, it seems many of +the problems affect only the more-general facilities for gcc's +@code{__complex__} type, such as @code{__complex__ int} +(where the real and imaginary parts are integers) that GNU +Fortran does not use. + +Version 0.5.20 of @code{g77} works around this +problem by not using the back end's support for @code{COMPLEX}. +The new option @samp{-fno-emulate-complex} avoids the work-around, +reverting to using the same ``broken'' mechanism as that used +by versions of @code{g77} prior to 0.5.20. + +@cindex ELF support +@cindex support, ELF +@cindex -fPIC option +@cindex options, -fPIC +@item +There seem to be some problems with passing constants, and perhaps +general expressions (other than simple variables/arrays), to procedures +when compiling on some systems (such as i386) with @samp{-fPIC}, as in +when compiling for ELF targets. +The symptom is that the assembler complains about invalid opcodes. +More investigation is needed, but the problem is almost certainly +in the gcc back end, and it apparently occurs only when +compiling sufficiently complicated functions @emph{without} the +@samp{-O} option. +@end itemize + diff --git a/gcc/f/bugs0.texi b/gcc/f/bugs0.texi new file mode 100644 index 000000000000..e8f6d22e3390 --- /dev/null +++ b/gcc/f/bugs0.texi @@ -0,0 +1,17 @@ +\input texinfo @c -*-texinfo-*- +@c %**start of header +@setfilename BUGS +@set BUGSONLY +@c %**end of header + +@c The immediately following lines apply to the BUGS file +@c which is generated using this file. +This file lists known bugs in the GNU Fortran compiler. +Copyright (C) 1995, 1996 Free Software Foundation, Inc. +You may copy, distribute, and modify it freely as long as you preserve +this copyright notice and permission notice. + +@node Top,,, (dir) +@chapter Bugs in GNU Fortran +@include bugs.texi +@bye diff --git a/gcc/f/com-rt.def b/gcc/f/com-rt.def new file mode 100644 index 000000000000..eb2fed5f530e --- /dev/null +++ b/gcc/f/com-rt.def @@ -0,0 +1,281 @@ +/* com-rt.def -- Public #include File (module.h template V1.0) + Copyright (C) 1995-1997 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + com.c + + Modifications: +*/ + +/* DEFGFRT(CODE,NAME,TYPE,VOLATILE,COMPLEX): + + CODE -- the #define name to use to refer to the function in g77 code + + NAME -- the name as seen by the back end and, with whatever massaging + is normal, the linker + + TYPE -- a code for the tree for the type, assigned when first encountered + (NOTE: There's a distinction made between the semantic return + value for the function, and the actual return mechanism; e.g. + `r_abs()' computes a single-precision `float' return value + but returns it as a `double'. This distinction is important + and is flagged via the _F2C_ versus _GNU_ suffix.) + + ARGS -- a string of codes representing the types of the arguments; the + last type specifies the type for that and all following args, + and the null pointer (0) means the same as "0": + + 0 Not applicable at and beyond this point + & Pointer to type that follows + a char + c complex + d doublereal + e doublecomplex + f real + i integer + j longint + + VOLATILE -- TRUE if the function never returns (gen's emit_barrier in + g77 back end) + + COMPLEX -- TRUE if the return value is COMPLEX or DOUBLE COMPLEX and + thus might need to be returned as ptr-to-1st-arg + +*/ + +DEFGFRT (FFECOM_gfrtCAT, "s_cat", FFECOM_rttypeVOID_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtCMP, "s_cmp", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtCOPY, "s_copy", FFECOM_rttypeVOID_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtPAUSE, "s_paus", FFECOM_rttypeVOID_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSTOP, "s_stop", FFECOM_rttypeVOID_, 0, TRUE, FALSE) + +DEFGFRT (FFECOM_gfrtSRDUE, "s_rdue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtERDUE, "e_rdue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSRSUE, "s_rsue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtERSUE, "e_rsue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSRDFE, "s_rdfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtERDFE, "e_rdfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSRSFI, "s_rsfi", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtERSFI, "e_rsfi", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSRSFE, "s_rsfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtERSFE, "e_rsfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSRSLI, "s_rsli", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtERSLI, "e_rsli", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSRSLE, "s_rsle", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtERSLE, "e_rsle", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSRSNE, "s_rsne", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) + +DEFGFRT (FFECOM_gfrtSWDUE, "s_wdue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtEWDUE, "e_wdue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSWSUE, "s_wsue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtEWSUE, "e_wsue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSWDFE, "s_wdfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtEWDFE, "e_wdfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSWSFI, "s_wsfi", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtEWSFI, "e_wsfi", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSWSFE, "s_wsfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtEWSFE, "e_wsfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSWSLI, "s_wsli", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtEWSLI, "e_wsli", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSWSLE, "s_wsle", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtEWSLE, "e_wsle", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSWSNE, "s_wsne", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) + +DEFGFRT (FFECOM_gfrtDOFIO, "do_fio", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDOLIO, "do_lio", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDOUIO, "do_uio", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) + +DEFGFRT (FFECOM_gfrtFOPEN, "f_open", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtFCLOS, "f_clos", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtFINQU, "f_inqu", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) + +DEFGFRT (FFECOM_gfrtFBACK, "f_back", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtFEND, "f_end", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtFREW, "f_rew", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) + +DEFGFRT (FFECOM_gfrtABORT, "G77_abort_0", FFECOM_rttypeVOID_, 0, TRUE, FALSE) +DEFGFRT (FFECOM_gfrtABS, "r_abs", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtACCESS, "G77_access_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtACOS, "r_acos", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtAIMAG, "r_imag", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtAINT, "r_int", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtALARM, "G77_alarm_0", FFECOM_rttypeVOID_, "&i0", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtALOG, "r_log", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtALOG10, "r_lg10", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtAMOD, "r_mod", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtANINT, "r_nint", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtASIN, "r_asin", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtATAN, "r_atan", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtATAN2, "r_atn2", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtCABS, "c_abs", FFECOM_rttypeREAL_F2C_, "&c", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtCCOS, "c_cos", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE) +DEFGFRT (FFECOM_gfrtCEXP, "c_exp", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE) +DEFGFRT (FFECOM_gfrtCHDIR, "G77_chdir_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtCLOG, "c_log", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE) +DEFGFRT (FFECOM_gfrtCHMOD, "G77_chmod_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtCONJG, "r_cnjg", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE) +DEFGFRT (FFECOM_gfrtCOS, "r_cos", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtCOSH, "r_cosh", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtCSIN, "c_sin", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE) +DEFGFRT (FFECOM_gfrtCSQRT, "c_sqrt", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE) +DEFGFRT (FFECOM_gfrtCTIME, "G77_ctime_0", FFECOM_rttypeCHARACTER_, "&j", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDABS, "d_abs", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDACOS, "d_acos", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDASIN, "d_asin", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDATAN, "d_atan", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDATAN2, "d_atn2", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDATE, "G77_date_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_BESJ0, "j0", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_BESJ1, "j1", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_BESJN, "jn", FFECOM_rttypeDOUBLE_, "id", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_BESY0, "y0", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_BESY1, "y1", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_BESYN, "yn", FFECOM_rttypeDOUBLE_, "id", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDCOS, "d_cos", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDCOSH, "d_cosh", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDDIM, "d_dim", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDERF, "G77_derf_0", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDERFC, "G77_derfc_0", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDEXP, "d_exp", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDIM, "r_dim", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDINT, "d_int", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDLOG, "d_log", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDLOG10, "d_lg10", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDMOD, "d_mod", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDNINT, "d_nint", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDPROD, "d_prod", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDSIGN, "d_sign", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDSIN, "d_sin", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDSINH, "d_sinh", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDSQRT, "d_sqrt", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDTAN, "d_tan", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDTANH, "d_tanh", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtDTIME, "G77_dtime_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtERF, "G77_erf_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtERFC, "G77_erfc_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtETIME, "G77_etime_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtEXIT, "G77_exit_0", FFECOM_rttypeVOID_, "&i", TRUE, FALSE) +DEFGFRT (FFECOM_gfrtEXP, "r_exp", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtFDATE, "G77_fdate_0", FFECOM_rttypeCHARACTER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtFGET, "G77_fget_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtFGETC, "G77_fgetc_0", FFECOM_rttypeINTEGER_, "&i&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtFLUSH, "G77_flush_0", FFECOM_rttypeVOID_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtFLUSH1, "G77_flush1_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtFNUM, "G77_fnum_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtFPUT, "G77_fput_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtFPUTC, "G77_fputc_0", FFECOM_rttypeINTEGER_, "&i&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtFSTAT, "G77_fstat_0", FFECOM_rttypeINTEGER_, "&i&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtFTELL, "G77_ftell_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtFSEEK, "G77_fseek_0", FFECOM_rttypeINTEGER_, "&i&i&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtGERROR, "G77_gerror_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtGETARG, "G77_getarg_0", FFECOM_rttypeVOID_, "&i&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtGETCWD, "G77_getcwd_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtGETGID, "G77_getgid_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtGETLOG, "G77_getlog_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtGETPID, "G77_getpid_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtGETUID, "G77_getuid_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtGETENV, "G77_getenv_0", FFECOM_rttypeVOID_, "&a&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtGMTIME, "G77_gmtime_0", FFECOM_rttypeVOID_, "&i&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtHOSTNM, "G77_hostnm_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtIABS, "i_abs", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtIARGC, "G77_iargc_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtIDATE, "G77_idate_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtIDIM, "i_dim", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtIDNINT, "i_dnnt", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtIERRNO, "G77_ierrno_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtINDEX, "i_indx", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtIRAND, "G77_irand_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtISIGN, "i_sign", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtISATTY, "G77_isatty_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtITIME, "G77_itime_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtKILL, "G77_kill_0", FFECOM_rttypeINTEGER_, "&i&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtLEN, "i_len", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtLGE, "l_ge", FFECOM_rttypeLOGICAL_, "&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtLGT, "l_gt", FFECOM_rttypeLOGICAL_, "&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtLINK, "G77_link_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtLLE, "l_le", FFECOM_rttypeLOGICAL_, "&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtLLT, "l_lt", FFECOM_rttypeLOGICAL_, "&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtLNBLNK, "G77_lnblnk_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtLSTAT, "G77_lstat_0", FFECOM_rttypeINTEGER_, "&a&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtLTIME, "G77_ltime_0", FFECOM_rttypeVOID_, "&i&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtMCLOCK, "G77_mclock_0", FFECOM_rttypeLONGINT_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtMOD, "i_mod", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtNINT, "i_nint", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtPERROR, "G77_perror_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtRAND, "G77_rand_0", FFECOM_rttypeREAL_F2C_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtRENAME, "G77_rename_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSECNDS, "G77_secnds_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSECOND, "G77_second_0", FFECOM_rttypeREAL_F2C_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSIGN, "r_sign", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_SIGNAL, "G77_signal_0", FFECOM_rttypeINTEGER_, "&i0", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSIN, "r_sin", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSINH, "r_sinh", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSLEEP, "G77_sleep_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSQRT, "r_sqrt", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSRAND, "G77_srand_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSTAT, "G77_stat_0", FFECOM_rttypeINTEGER_, "&a&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSYMLNK, "G77_symlnk_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSYSTEM, "G77_system_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtSYSTEM_CLOCK, "system_clock_", FFECOM_rttypeVOID_, "&i&i&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtTAN, "r_tan", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtTANH, "r_tanh", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtTIME, "G77_time_0", FFECOM_rttypeLONGINT_, 0, FALSE, FALSE) +DEFGFRT (FFECOM_gfrtTTYNAM, "G77_ttynam_0", FFECOM_rttypeCHARACTER_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtUNLINK, "G77_unlink_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtUMASK, "G77_umask_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtVXTIDATE, "G77_vxtidate_0", FFECOM_rttypeVOID_, "&i&i&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtVXTTIME, "G77_vxttime_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtCDABS, "z_abs", FFECOM_rttypeDOUBLE_, "&e", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtCDCOS, "z_cos", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE) +DEFGFRT (FFECOM_gfrtCDEXP, "z_exp", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE) +DEFGFRT (FFECOM_gfrtCDLOG, "z_log", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE) +DEFGFRT (FFECOM_gfrtDCONJG, "d_cnjg", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE) +DEFGFRT (FFECOM_gfrtCDSIN, "z_sin", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE) +DEFGFRT (FFECOM_gfrtCDSQRT, "z_sqrt", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE) +DEFGFRT (FFECOM_gfrtDIMAG, "d_imag", FFECOM_rttypeDOUBLE_, "&e", FALSE, FALSE) + +DEFGFRT (FFECOM_gfrtL_ACOS, "acos", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_ASIN, "asin", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_ATAN, "atan", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_ATAN2, "atan2", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_COS, "__builtin_cos", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_COSH, "cosh", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_ERF, "erf", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_ERFC, "erfc", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_EXP, "exp", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_FLOOR, "floor", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_LOG, "log", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_SIN, "__builtin_sin", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_SINH, "sinh", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_SQRT, "__builtin_fsqrt", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_TAN, "tan", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtL_TANH, "tanh", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE) + +DEFGFRT (FFECOM_gfrtPOW_CI, "pow_ci", FFECOM_rttypeCOMPLEX_F2C_, "&c&i", FALSE, TRUE) +DEFGFRT (FFECOM_gfrtPOW_DD, "pow_dd", FFECOM_rttypeDOUBLE_, "&d&d", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtPOW_DI, "pow_di", FFECOM_rttypeDOUBLE_, "&d&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtPOW_II, "pow_ii", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtPOW_QQ, "pow_qq", FFECOM_rttypeLONGINT_, "&j&j", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtPOW_RI, "pow_ri", FFECOM_rttypeREAL_F2C_, "&f&i", FALSE, FALSE) +DEFGFRT (FFECOM_gfrtPOW_ZI, "pow_zi", FFECOM_rttypeDBLCMPLX_F2C_, "&e&i", FALSE, TRUE) +DEFGFRT (FFECOM_gfrtPOW_ZZ, "pow_zz", FFECOM_rttypeDBLCMPLX_F2C_, "&e&e", FALSE, TRUE) +DEFGFRT (FFECOM_gfrtDIV_CC, "c_div", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE) +DEFGFRT (FFECOM_gfrtDIV_ZZ, "z_div", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE) diff --git a/gcc/f/com.c b/gcc/f/com.c new file mode 100644 index 000000000000..65a6ea9c2829 --- /dev/null +++ b/gcc/f/com.c @@ -0,0 +1,16225 @@ +/* com.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995-1997 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + None + + Description: + Contains compiler-specific functions. + + Modifications: +*/ + +/* Understanding this module means understanding the interface between + the g77 front end and the gcc back end (or, perhaps, some other + back end). In here are the functions called by the front end proper + to notify whatever back end is in place about certain things, and + also the back-end-specific functions. It's a bear to deal with, so + lately I've been trying to simplify things, especially with regard + to the gcc-back-end-specific stuff. + + Building expressions generally seems quite easy, but building decls + has been challenging and is undergoing revision. gcc has several + kinds of decls: + + TYPE_DECL -- a type (int, float, struct, function, etc.) + CONST_DECL -- a constant of some type other than function + LABEL_DECL -- a variable or a constant? + PARM_DECL -- an argument to a function (a variable that is a dummy) + RESULT_DECL -- the return value of a function (a variable) + VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.) + FUNCTION_DECL -- a function (either the actual function or an extern ref) + FIELD_DECL -- a field in a struct or union (goes into types) + + g77 has a set of functions that somewhat parallels the gcc front end + when it comes to building decls: + + Internal Function (one we define, not just declare as extern): + int yes; + yes = suspend_momentary (); + if (is_nested) push_f_function_context (); + start_function (get_identifier ("function_name"), function_type, + is_nested, is_public); + // for each arg, build PARM_DECL and call push_parm_decl (decl) with it; + store_parm_decls (is_main_program); + ffecom_start_compstmt_ (); + // for stmts and decls inside function, do appropriate things; + ffecom_end_compstmt_ (); + finish_function (is_nested); + if (is_nested) pop_f_function_context (); + if (is_nested) resume_momentary (yes); + + Everything Else: + int yes; + tree d; + tree init; + yes = suspend_momentary (); + // fill in external, public, static, &c for decl, and + // set DECL_INITIAL to error_mark_node if going to initialize + // set is_top_level TRUE only if not at top level and decl + // must go in top level (i.e. not within current function decl context) + d = start_decl (decl, is_top_level); + init = ...; // if have initializer + finish_decl (d, init, is_top_level); + resume_momentary (yes); + +*/ + +/* Include files. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +#include "config.j" +#include "flags.j" +#include "rtl.j" +#include "tree.j" +#include "convert.j" +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + +#define FFECOM_GCC_INCLUDE 1 /* Enable -I. */ + +/* BEGIN stuff from gcc/cccp.c. */ + +/* The following symbols should be autoconfigured: + HAVE_FCNTL_H + HAVE_STDLIB_H + HAVE_SYS_TIME_H + HAVE_UNISTD_H + STDC_HEADERS + TIME_WITH_SYS_TIME + In the mean time, we'll get by with approximations based + on existing GCC configuration symbols. */ + +#ifdef POSIX +# ifndef HAVE_STDLIB_H +# define HAVE_STDLIB_H 1 +# endif +# ifndef HAVE_UNISTD_H +# define HAVE_UNISTD_H 1 +# endif +# ifndef STDC_HEADERS +# define STDC_HEADERS 1 +# endif +#endif /* defined (POSIX) */ + +#if defined (POSIX) || (defined (USG) && !defined (VMS)) +# ifndef HAVE_FCNTL_H +# define HAVE_FCNTL_H 1 +# endif +#endif + +#ifndef RLIMIT_STACK +# include +#else +# if TIME_WITH_SYS_TIME +# include +# include +# else +# if HAVE_SYS_TIME_H +# include +# else +# include +# endif +# endif +# include +#endif + +#if HAVE_FCNTL_H +# include +#endif + +/* This defines "errno" properly for VMS, and gives us EACCES. */ +#include + +#if HAVE_STDLIB_H +# include +#else +char *getenv (); +#endif + +char *index (); +char *rindex (); + +#if HAVE_UNISTD_H +# include +#endif + +/* VMS-specific definitions */ +#ifdef VMS +#include +#define O_RDONLY 0 /* Open arg for Read/Only */ +#define O_WRONLY 1 /* Open arg for Write/Only */ +#define read(fd,buf,size) VMS_read (fd,buf,size) +#define write(fd,buf,size) VMS_write (fd,buf,size) +#define open(fname,mode,prot) VMS_open (fname,mode,prot) +#define fopen(fname,mode) VMS_fopen (fname,mode) +#define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile) +#define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt) +#define fstat(fd,stbuf) VMS_fstat (fd,stbuf) +static int VMS_fstat (), VMS_stat (); +static char * VMS_strncat (); +static int VMS_read (); +static int VMS_write (); +static int VMS_open (); +static FILE * VMS_fopen (); +static FILE * VMS_freopen (); +static void hack_vms_include_specification (); +typedef struct { unsigned :16, :16, :16; } vms_ino_t; +#define ino_t vms_ino_t +#define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */ +#ifdef __GNUC__ +#define BSTRING /* VMS/GCC supplies the bstring routines */ +#endif /* __GNUC__ */ +#endif /* VMS */ + +#ifndef O_RDONLY +#define O_RDONLY 0 +#endif + +/* END stuff from gcc/cccp.c. */ + +#include "proj.h" +#define FFECOM_DETERMINE_TYPES 1 /* for com.h */ +#include "com.h" +#include "bad.h" +#include "bld.h" +#include "equiv.h" +#include "expr.h" +#include "implic.h" +#include "info.h" +#include "malloc.h" +#include "src.h" +#include "st.h" +#include "storag.h" +#include "symbol.h" +#include "target.h" +#include "top.h" +#include "type.h" + +/* Externals defined here. */ + +#define FFECOM_FASTER_ARRAY_REFS 0 /* Generates faster code? */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + +/* tree.h declares a bunch of stuff that it expects the front end to + define. Here are the definitions, which in the C front end are + found in the file c-decl.c. */ + +tree integer_zero_node; +tree integer_one_node; +tree null_pointer_node; +tree error_mark_node; +tree void_type_node; +tree integer_type_node; +tree unsigned_type_node; +tree char_type_node; +tree current_function_decl; + +/* ~~tree.h SHOULD declare this, because toplev.c and dwarfout.c reference + it. */ + +char *language_string = "GNU F77"; + +/* These definitions parallel those in c-decl.c so that code from that + module can be used pretty much as is. Much of these defs aren't + otherwise used, i.e. by g77 code per se, except some of them are used + to build some of them that are. The ones that are global (i.e. not + "static") are those that ste.c and such might use (directly + or by using com macros that reference them in their definitions). */ + +static tree short_integer_type_node; +tree long_integer_type_node; +static tree long_long_integer_type_node; + +static tree short_unsigned_type_node; +static tree long_unsigned_type_node; +static tree long_long_unsigned_type_node; + +static tree unsigned_char_type_node; +static tree signed_char_type_node; + +static tree float_type_node; +static tree double_type_node; +static tree complex_float_type_node; +tree complex_double_type_node; +static tree long_double_type_node; +static tree complex_integer_type_node; +static tree complex_long_double_type_node; + +tree string_type_node; + +static tree double_ftype_double; +static tree float_ftype_float; +static tree ldouble_ftype_ldouble; + +/* The rest of these are inventions for g77, though there might be + similar things in the C front end. As they are found, these + inventions should be renamed to be canonical. Note that only + the ones currently required to be global are so. */ + +static tree ffecom_tree_fun_type_void; +static tree ffecom_tree_ptr_to_fun_type_void; + +tree ffecom_integer_type_node; /* Abbrev for _tree_type[blah][blah]. */ +tree ffecom_integer_zero_node; /* Like *_*_* with g77's integer type. */ +tree ffecom_integer_one_node; /* " */ +tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype]; + +/* _fun_type things are the f2c-specific versions. For -fno-f2c, + just use build_function_type and build_pointer_type on the + appropriate _tree_type array element. */ + +static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype]; +static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype]; +static tree ffecom_tree_subr_type; +static tree ffecom_tree_ptr_to_subr_type; +static tree ffecom_tree_blockdata_type; + +static tree ffecom_tree_xargc_; + +ffecomSymbol ffecom_symbol_null_ += +{ + NULL_TREE, + NULL_TREE, + NULL_TREE, +}; +ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE; +ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE; + +int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype]; +tree ffecom_f2c_integer_type_node; +tree ffecom_f2c_ptr_to_integer_type_node; +tree ffecom_f2c_address_type_node; +tree ffecom_f2c_real_type_node; +tree ffecom_f2c_ptr_to_real_type_node; +tree ffecom_f2c_doublereal_type_node; +tree ffecom_f2c_complex_type_node; +tree ffecom_f2c_doublecomplex_type_node; +tree ffecom_f2c_longint_type_node; +tree ffecom_f2c_logical_type_node; +tree ffecom_f2c_flag_type_node; +tree ffecom_f2c_ftnlen_type_node; +tree ffecom_f2c_ftnlen_zero_node; +tree ffecom_f2c_ftnlen_one_node; +tree ffecom_f2c_ftnlen_two_node; +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. */ + +#ifndef FFECOM_sizeMAXSTACKITEM +#define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things + larger than this # bytes + off stack if possible. */ +#endif + +/* For systems that have large enough stacks, they should define + this to 0, and here, for ease of use later on, we just undefine + it if it is 0. */ + +#if FFECOM_sizeMAXSTACKITEM == 0 +#undef FFECOM_sizeMAXSTACKITEM +#endif + +typedef enum + { + FFECOM_rttypeVOID_, + FFECOM_rttypeINT_, /* C's `int' type, for libF77/system_.c? */ + FFECOM_rttypeINTEGER_, + FFECOM_rttypeLONGINT_, /* C's `long long int' type. */ + FFECOM_rttypeLOGICAL_, + FFECOM_rttypeREAL_F2C_, /* f2c's `float' returned as `double'. */ + FFECOM_rttypeREAL_GNU_, /* `float' returned as such. */ + FFECOM_rttypeCOMPLEX_F2C_, /* f2c's `complex' returned via 1st arg. */ + FFECOM_rttypeCOMPLEX_GNU_, /* gcc's `complex float' returned as such. */ + FFECOM_rttypeDOUBLE_, /* C's `double' type. */ + FFECOM_rttypeDOUBLEREAL_, + FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */ + FFECOM_rttypeDBLCMPLX_GNU_, /* gcc's `complex double' returned as such. */ + FFECOM_rttypeCHARACTER_, /* f2c `char *'/`ftnlen' pair. */ + FFECOM_rttype_ + } ffecomRttype_; + +/* Internal typedefs. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +typedef struct _ffecom_concat_list_ ffecomConcatList_; +typedef struct _ffecom_temp_ *ffecomTemp_; +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + +/* Private include files. */ + + +/* Internal structure definitions. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +struct _ffecom_concat_list_ + { + ffebld *exprs; + int count; + int max; + ffetargetCharacterSize minlen; + ffetargetCharacterSize maxlen; + }; + +struct _ffecom_temp_ + { + ffecomTemp_ next; + tree type; /* Base type (w/o size/array applied). */ + tree t; + ffetargetCharacterSize size; + int elements; + bool in_use; + bool auto_pop; + }; + +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + +/* Static functions (internal). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree ffecom_arglist_expr_ (char *argstring, ffebld args); +static tree ffecom_widest_expr_type_ (ffebld list); +static bool ffecom_overlap_ (tree dest_decl, tree dest_offset, + tree dest_size, tree source_tree, + ffebld source, bool scalar_arg); +static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest, + tree args, tree callee_commons, + bool scalar_args); +static tree ffecom_build_f2c_string_ (int i, char *s); +static tree ffecom_call_ (tree fn, ffeinfoKindtype kt, + bool is_f2c_complex, tree type, + tree args, tree dest_tree, + ffebld dest, bool *dest_used, + tree callee_commons, bool scalar_args); +static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, + bool is_f2c_complex, tree type, + ffebld left, ffebld right, + tree dest_tree, ffebld dest, + bool *dest_used, tree callee_commons, + bool scalar_args); +static void ffecom_char_args_ (tree *xitem, tree *length, + ffebld expr); +static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy); +static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s); +static ffecomConcatList_ + ffecom_concat_list_gather_ (ffecomConcatList_ catlist, + ffebld expr, + ffetargetCharacterSize max); +static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist); +static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr, + ffetargetCharacterSize max); +static void ffecom_debug_kludge_ (tree aggr, char *aggr_type, ffesymbol member, + tree member_type, ffetargetOffset offset); +static void ffecom_do_entry_ (ffesymbol fn, int entrynum); +static tree ffecom_expr_ (ffebld expr, tree dest_tree, + ffebld dest, bool *dest_used, + bool assignp); +static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, + ffebld dest, bool *dest_used); +static tree ffecom_expr_power_integer_ (ffebld left, ffebld right); +static void ffecom_expr_transform_ (ffebld expr); +static void ffecom_f2c_make_type_ (tree *type, int tcode, char *name); +static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size, + int code); +static ffeglobal ffecom_finish_global_ (ffeglobal global); +static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s); +static tree ffecom_get_appended_identifier_ (char us, char *text); +static tree ffecom_get_external_identifier_ (ffesymbol s); +static tree ffecom_get_identifier_ (char *text); +static tree ffecom_gen_sfuncdef_ (ffesymbol s, + ffeinfoBasictype bt, + ffeinfoKindtype kt); +static char *ffecom_gfrt_args_ (ffecomGfrt ix); +static tree ffecom_gfrt_tree_ (ffecomGfrt ix); +static tree ffecom_init_zero_ (tree decl); +static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg, + tree *maybe_tree); +static tree ffecom_intrinsic_len_ (ffebld expr); +static void ffecom_let_char_ (tree dest_tree, + tree dest_length, + ffetargetCharacterSize dest_size, + ffebld source); +static void ffecom_make_gfrt_ (ffecomGfrt ix); +static void ffecom_member_phase1_ (ffestorag mst, ffestorag st); +#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING +static void ffecom_member_phase2_ (ffestorag mst, ffestorag st); +#endif +static void ffecom_push_dummy_decls_ (ffebld dumlist, + bool stmtfunc); +static void ffecom_start_progunit_ (void); +static ffesymbol ffecom_sym_transform_ (ffesymbol s); +static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s); +static void ffecom_transform_common_ (ffesymbol s); +static void ffecom_transform_equiv_ (ffestorag st); +static tree ffecom_transform_namelist_ (ffesymbol s); +static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset, + tree t); +static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset, + tree *size, tree tree); +static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right, + tree dest_tree, ffebld dest, + bool *dest_used); +static tree ffecom_type_localvar_ (ffesymbol s, + ffeinfoBasictype bt, + ffeinfoKindtype kt); +static tree ffecom_type_namelist_ (void); +#if 0 +static tree ffecom_type_permanent_copy_ (tree t); +#endif +static tree ffecom_type_vardesc_ (void); +static tree ffecom_vardesc_ (ffebld expr); +static tree ffecom_vardesc_array_ (ffesymbol s); +static tree ffecom_vardesc_dims_ (ffesymbol s); +#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 void bison_rule_compstmt_ (void); +static void bison_rule_pushlevel_ (void); +static tree builtin_function (char *name, tree type, + enum built_in_function function_code, + char *library_name); +static int duplicate_decls (tree newdecl, tree olddecl); +static void finish_decl (tree decl, tree init, bool is_top_level); +static void finish_function (int nested); +static char *lang_printable_name (tree decl, char **kind); +static tree lookup_name_current_level (tree name); +static struct binding_level *make_binding_level (void); +static void pop_f_function_context (void); +static void push_f_function_context (void); +static void push_parm_decl (tree parm); +static tree pushdecl_top_level (tree decl); +static tree storedecls (tree decls); +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_ (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_primary_entry_ = NULL; +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_; +static ffecomTemp_ ffecom_latest_temp_; +static int ffecom_pending_calls_ = 0; +static tree ffecom_float_zero_ = NULL_TREE; +static tree ffecom_float_half_ = NULL_TREE; +static tree ffecom_double_zero_ = NULL_TREE; +static tree ffecom_double_half_ = NULL_TREE; +static tree ffecom_func_result_;/* For functions. */ +static tree ffecom_func_length_;/* For CHARACTER fns. */ +static ffebld ffecom_list_blockdata_; +static ffebld ffecom_list_common_; +static ffebld ffecom_master_arglist_; +static ffeinfoBasictype ffecom_master_bt_; +static ffeinfoKindtype ffecom_master_kt_; +static ffetargetCharacterSize ffecom_master_size_; +static int ffecom_num_fns_ = 0; +static int ffecom_num_entrypoints_ = 0; +static bool ffecom_is_altreturning_ = FALSE; +static tree ffecom_multi_type_node_; +static tree ffecom_multi_retval_; +static tree + ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype]; +static bool ffecom_member_namelisted_; /* _member_phase1_ namelisted? */ +static bool ffecom_doing_entry_ = FALSE; +static bool ffecom_transform_only_dummies_ = FALSE; + +/* Holds pointer-to-function expressions. */ + +static tree ffecom_gfrt_[FFECOM_gfrt] += +{ +#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NULL_TREE, +#include "com-rt.def" +#undef DEFGFRT +}; + +/* Holds the external names of the functions. */ + +static char *ffecom_gfrt_name_[FFECOM_gfrt] += +{ +#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NAME, +#include "com-rt.def" +#undef DEFGFRT +}; + +/* Whether the function returns. */ + +static bool ffecom_gfrt_volatile_[FFECOM_gfrt] += +{ +#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) VOLATILE, +#include "com-rt.def" +#undef DEFGFRT +}; + +/* Whether the function returns type complex. */ + +static bool ffecom_gfrt_complex_[FFECOM_gfrt] += +{ +#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) COMPLEX, +#include "com-rt.def" +#undef DEFGFRT +}; + +/* Type code for the function return value. */ + +static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt] += +{ +#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) TYPE, +#include "com-rt.def" +#undef DEFGFRT +}; + +/* String of codes for the function's arguments. */ + +static char *ffecom_gfrt_argstring_[FFECOM_gfrt] += +{ +#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) ARGS, +#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, + it would be best to do something here to figure out automatically + from other information what type to use. */ + +/* NOTE: g77 currently doesn't use these; see setting of sizetype and + change that if you need to. -- jcb 09/01/91. */ + +#ifndef SIZE_TYPE +#define SIZE_TYPE "long unsigned int" +#endif + +#ifndef WCHAR_TYPE +#define WCHAR_TYPE "int" +#endif + +#define ffecom_concat_list_count_(catlist) ((catlist).count) +#define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)]) +#define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen) +#define ffecom_concat_list_minlen_(catlist) ((catlist).minlen) + +#define ffecom_start_compstmt_ bison_rule_pushlevel_ +#define ffecom_end_compstmt_ bison_rule_compstmt_ + +/* For each binding contour we allocate a binding_level structure + * which records the names defined in that contour. + * Contours include: + * 0) the global one + * 1) one for each function definition, + * where internal declarations of the parameters appear. + * + * The current meaning of a name can be found by searching the levels from + * the current one out to the global one. + */ + +/* Note that the information in the `names' component of the global contour + is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */ + +struct binding_level + { + /* A chain of _DECL nodes for all variables, constants, functions, and + typedef types. These are in the reverse of the order supplied. */ + tree names; + + /* For each level (except not the global one), a chain of BLOCK nodes for + all the levels that were entered and exited one level down. */ + tree blocks; + + /* The BLOCK node for this level, if one has been preallocated. If 0, the + BLOCK is allocated (if needed) when the level is popped. */ + tree this_block; + + /* The binding level which this one is contained in (inherits from). */ + struct binding_level *level_chain; + }; + +#define NULL_BINDING_LEVEL (struct binding_level *) NULL + +/* The binding level currently in effect. */ + +static struct binding_level *current_binding_level; + +/* A chain of binding_level structures awaiting reuse. */ + +static struct binding_level *free_binding_level; + +/* The outermost binding level, for names of file scope. + This is created when the compiler is started and exists + through the entire run. */ + +static struct binding_level *global_binding_level; + +/* Binding level structures are initialized by copying this one. */ + +static struct binding_level clear_binding_level += +{NULL, NULL, NULL, NULL_BINDING_LEVEL}; + +/* Language-dependent contents of an identifier. */ + +struct lang_identifier + { + struct tree_identifier ignore; + tree global_value, local_value, label_value; + bool invented; + }; + +/* Macros for access to language-specific slots in an identifier. */ +/* Each of these slots contains a DECL node or null. */ + +/* This represents the value which the identifier has in the + file-scope namespace. */ +#define IDENTIFIER_GLOBAL_VALUE(NODE) \ + (((struct lang_identifier *)(NODE))->global_value) +/* This represents the value which the identifier has in the current + scope. */ +#define IDENTIFIER_LOCAL_VALUE(NODE) \ + (((struct lang_identifier *)(NODE))->local_value) +/* This represents the value which the identifier has as a label in + the current label scope. */ +#define IDENTIFIER_LABEL_VALUE(NODE) \ + (((struct lang_identifier *)(NODE))->label_value) +/* This is nonzero if the identifier was "made up" by g77 code. */ +#define IDENTIFIER_INVENTED(NODE) \ + (((struct lang_identifier *)(NODE))->invented) + +/* In identifiers, C uses the following fields in a special way: + TREE_PUBLIC to record that there was a previous local extern decl. + TREE_USED to record that such a decl was used. + TREE_ADDRESSABLE to record that the address of such a decl was used. */ + +/* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function + that have names. Here so we can clear out their names' definitions + at the end of the function. */ + +static tree named_labels; + +/* A list of LABEL_DECLs from outer contexts that are currently shadowed. */ + +static tree shadowed_labels; + +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + + +/* This is like gcc's stabilize_reference -- in fact, most of the code + comes from that -- but it handles the situation where the reference + is going to have its subparts picked at, and it shouldn't change + (or trigger extra invocations of functions in the subtrees) due to + this. save_expr is a bit overzealous, because we don't need the + entire thing calculated and saved like a temp. So, for DECLs, no + change is needed, because these are stable aggregates, and ARRAY_REF + 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) +{ + tree result; + enum tree_code code = TREE_CODE (ref); + + switch (code) + { + case VAR_DECL: + case PARM_DECL: + case RESULT_DECL: + /* No action is needed in this case. */ + return ref; + + case NOP_EXPR: + case CONVERT_EXPR: + case FLOAT_EXPR: + case FIX_TRUNC_EXPR: + case FIX_FLOOR_EXPR: + case FIX_ROUND_EXPR: + case FIX_CEIL_EXPR: + result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0))); + break; + + case INDIRECT_REF: + result = build_nt (INDIRECT_REF, + stabilize_reference_1 (TREE_OPERAND (ref, 0))); + break; + + case COMPONENT_REF: + result = build_nt (COMPONENT_REF, + stabilize_reference (TREE_OPERAND (ref, 0)), + TREE_OPERAND (ref, 1)); + break; + + case BIT_FIELD_REF: + result = build_nt (BIT_FIELD_REF, + stabilize_reference (TREE_OPERAND (ref, 0)), + stabilize_reference_1 (TREE_OPERAND (ref, 1)), + stabilize_reference_1 (TREE_OPERAND (ref, 2))); + break; + + case ARRAY_REF: + result = build_nt (ARRAY_REF, + stabilize_reference (TREE_OPERAND (ref, 0)), + stabilize_reference_1 (TREE_OPERAND (ref, 1))); + break; + + case COMPOUND_EXPR: + result = build_nt (COMPOUND_EXPR, + stabilize_reference_1 (TREE_OPERAND (ref, 0)), + stabilize_reference (TREE_OPERAND (ref, 1))); + break; + + case RTL_EXPR: + result = build1 (INDIRECT_REF, TREE_TYPE (ref), + save_expr (build1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (ref)), + ref))); + break; + + + default: + return save_expr (ref); + + case ERROR_MARK: + return error_mark_node; + } + + TREE_TYPE (result) = TREE_TYPE (ref); + TREE_READONLY (result) = TREE_READONLY (ref); + TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref); + TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref); + TREE_RAISES (result) = TREE_RAISES (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) +{ + register enum tree_code form = TREE_CODE (TREE_TYPE (expr)); + tree subtype; + + 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); + return ffecom_2 (COMPLEX_EXPR, type, expr, + convert (subtype, integer_zero_node)); + } + + if (form == RECORD_TYPE) + { + tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))); + if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype)) + return expr; + else + { + expr = save_expr (expr); + return ffecom_2 (COMPLEX_EXPR, + type, + convert (subtype, + ffecom_1 (REALPART_EXPR, + TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))), + expr)), + convert (subtype, + ffecom_1 (IMAGPART_EXPR, + TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))), + expr))); + } + } + + if (form == POINTER_TYPE || form == REFERENCE_TYPE) + 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; +{ + register tree e = expr; + register enum tree_code code = TREE_CODE (type); + + if (type == TREE_TYPE (e) + || TREE_CODE (e) == ERROR_MARK) + return e; + if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e))) + return fold (build1 (NOP_EXPR, type, e)); + if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK + || code == ERROR_MARK) + return error_mark_node; + if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE) + { + assert ("void value not ignored as it ought to be" == NULL); + return error_mark_node; + } + assert (code != VOID_TYPE); + if ((code != RECORD_TYPE) + && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE)) + assert ("converting COMPLEX to REAL" == NULL); + assert (code != ENUMERAL_TYPE); + if (code == INTEGER_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE); + assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e))); + return fold (convert_to_integer (type, e)); + } + if (code == POINTER_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE); + return fold (convert_to_pointer (type, e)); + } + if (code == REAL_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE); + assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e))); + return fold (convert_to_real (type, e)); + } + if (code == COMPLEX_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE); + assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e)))); + return fold (convert_to_complex (type, e)); + } + if (code == RECORD_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE); + assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type))) + <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))))); + return fold (ffecom_convert_to_complex_ (type, e)); + } + + 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; +{ + register tree e = expr; + register enum tree_code code = TREE_CODE (type); + + if (type == TREE_TYPE (e) + || TREE_CODE (e) == ERROR_MARK) + return e; + if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e))) + return fold (build1 (NOP_EXPR, type, e)); + if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK + || code == ERROR_MARK) + return error_mark_node; + if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE) + { + assert ("void value not ignored as it ought to be" == NULL); + return error_mark_node; + } + assert (code != VOID_TYPE); + if ((code != RECORD_TYPE) + && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE)) + assert ("narrowing COMPLEX to REAL" == NULL); + assert (code != ENUMERAL_TYPE); + if (code == INTEGER_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE); + assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e))); + return fold (convert_to_integer (type, e)); + } + if (code == POINTER_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE); + return fold (convert_to_pointer (type, e)); + } + if (code == REAL_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE); + assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e))); + return fold (convert_to_real (type, e)); + } + if (code == COMPLEX_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE); + assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e)))); + return fold (convert_to_complex (type, e)); + } + if (code == RECORD_TYPE) + { + assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE); + assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type))) + >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))))); + return fold (ffecom_convert_to_complex_ (type, e)); + } + + 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) +{ + tree type; + tree realfield; + tree imagfield; + + if (ffe_is_emulate_complex ()) + { + type = make_node (RECORD_TYPE); + realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype); + imagfield = ffecom_decl_field (type, realfield, "i", subtype); + TYPE_FIELDS (type) = realfield; + layout_type (type); + } + else + { + type = make_node (COMPLEX_TYPE); + TREE_TYPE (type) = subtype; + layout_type (type); + } + + 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) +{ + tree bothparts; + + if (ffe_is_emulate_complex ()) + { + bothparts = build_tree_list (TYPE_FIELDS (type), realpart); + TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart); + bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts); + } + else + { + bothparts = build_complex (type, realpart, imagpart); + } + + return bothparts; +} +#endif + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_arglist_expr_ (char *c, ffebld expr) +{ + tree list; + tree *plist = &list; + tree trail = NULL_TREE; /* Append char length args here. */ + tree *ptrail = &trail; + tree length; + ffebld exprh; + tree item; + bool ptr = FALSE; + tree wanted = NULL_TREE; + + while (expr != NULL) + { + if (*c != '\0') + { + ptr = FALSE; + if (*c == '&') + { + ptr = TRUE; + ++c; + } + switch (*(c++)) + { + case '\0': + ptr = TRUE; + wanted = NULL_TREE; + break; + + case 'a': + assert (ptr); + wanted = NULL_TREE; + break; + + case 'c': + wanted = ffecom_f2c_complex_type_node; + break; + + case 'd': + wanted = ffecom_f2c_doublereal_type_node; + break; + + case 'e': + wanted = ffecom_f2c_doublecomplex_type_node; + break; + + case 'f': + wanted = ffecom_f2c_real_type_node; + break; + + case 'i': + wanted = ffecom_f2c_integer_type_node; + break; + + case 'j': + wanted = ffecom_f2c_longint_type_node; + break; + + default: + assert ("bad argstring code" == NULL); + wanted = NULL_TREE; + break; + } + } + + exprh = ffebld_head (expr); + if (exprh == NULL) + wanted = NULL_TREE; + + if ((wanted == NULL_TREE) + || (ptr + && (TYPE_MODE + (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))] + [ffeinfo_kindtype (ffebld_info (exprh))]) + == TYPE_MODE (wanted)))) + *plist + = build_tree_list (NULL_TREE, + ffecom_arg_ptr_to_expr (exprh, + &length)); + else + { + item = ffecom_arg_expr (exprh, &length); + item = ffecom_convert_widen_ (wanted, item); + if (ptr) + { + item = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (item)), + item); + } + *plist + = build_tree_list (NULL_TREE, + item); + } + + plist = &TREE_CHAIN (*plist); + expr = ffebld_trail (expr); + if (length != NULL_TREE) + { + *ptrail = build_tree_list (NULL_TREE, length); + ptrail = &TREE_CHAIN (*ptrail); + } + } + + *plist = trail; + + return list; +} +#endif + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_widest_expr_type_ (ffebld list) +{ + ffebld item; + ffebld widest = NULL; + ffetype type; + ffetype widest_type = NULL; + tree t; + + for (; list != NULL; list = ffebld_trail (list)) + { + item = ffebld_head (list); + if (item == NULL) + continue; + if ((widest != NULL) + && (ffeinfo_basictype (ffebld_info (item)) + != ffeinfo_basictype (ffebld_info (widest)))) + continue; + type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)), + ffeinfo_kindtype (ffebld_info (item))); + if ((widest == FFEINFO_kindtypeNONE) + || (ffetype_size (type) + > ffetype_size (widest_type))) + { + widest = item; + widest_type = type; + } + } + + assert (widest != NULL); + t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))] + [ffeinfo_kindtype (ffebld_info (widest))]; + assert (t != NULL_TREE); + return t; +} +#endif + +/* Check whether dest and source might overlap. ffebld versions of these + might or might not be passed, will be NULL if not. + + The test is really whether source_tree is modifiable and, if modified, + might overlap destination such that the value(s) in the destination might + 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, + bool scalar_arg) +{ + tree source_decl; + tree source_offset; + tree source_size; + tree t; + + if (source_tree == NULL_TREE) + return FALSE; + + switch (TREE_CODE (source_tree)) + { + case ERROR_MARK: + case IDENTIFIER_NODE: + case INTEGER_CST: + case REAL_CST: + case COMPLEX_CST: + case STRING_CST: + case CONST_DECL: + case VAR_DECL: + case RESULT_DECL: + case FIELD_DECL: + case MINUS_EXPR: + case MULT_EXPR: + case TRUNC_DIV_EXPR: + case CEIL_DIV_EXPR: + case FLOOR_DIV_EXPR: + case ROUND_DIV_EXPR: + case TRUNC_MOD_EXPR: + case CEIL_MOD_EXPR: + case FLOOR_MOD_EXPR: + case ROUND_MOD_EXPR: + case RDIV_EXPR: + case EXACT_DIV_EXPR: + case FIX_TRUNC_EXPR: + case FIX_CEIL_EXPR: + case FIX_FLOOR_EXPR: + case FIX_ROUND_EXPR: + case FLOAT_EXPR: + case EXPON_EXPR: + case NEGATE_EXPR: + case MIN_EXPR: + case MAX_EXPR: + case ABS_EXPR: + case FFS_EXPR: + case LSHIFT_EXPR: + case RSHIFT_EXPR: + case LROTATE_EXPR: + case RROTATE_EXPR: + case BIT_IOR_EXPR: + case BIT_XOR_EXPR: + case BIT_AND_EXPR: + case BIT_ANDTC_EXPR: + case BIT_NOT_EXPR: + case TRUTH_ANDIF_EXPR: + case TRUTH_ORIF_EXPR: + case TRUTH_AND_EXPR: + case TRUTH_OR_EXPR: + case TRUTH_XOR_EXPR: + case TRUTH_NOT_EXPR: + case LT_EXPR: + case LE_EXPR: + case GT_EXPR: + case GE_EXPR: + case EQ_EXPR: + case NE_EXPR: + case COMPLEX_EXPR: + case CONJ_EXPR: + case REALPART_EXPR: + case IMAGPART_EXPR: + case LABEL_EXPR: + case COMPONENT_REF: + return FALSE; + + case COMPOUND_EXPR: + return ffecom_overlap_ (dest_decl, dest_offset, dest_size, + TREE_OPERAND (source_tree, 1), NULL, + scalar_arg); + + case MODIFY_EXPR: + return ffecom_overlap_ (dest_decl, dest_offset, dest_size, + TREE_OPERAND (source_tree, 0), NULL, + scalar_arg); + + case CONVERT_EXPR: + case NOP_EXPR: + case NON_LVALUE_EXPR: + case PLUS_EXPR: + if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE) + return TRUE; + + ffecom_tree_canonize_ptr_ (&source_decl, &source_offset, + source_tree); + source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree))); + break; + + case COND_EXPR: + return + ffecom_overlap_ (dest_decl, dest_offset, dest_size, + TREE_OPERAND (source_tree, 1), NULL, + scalar_arg) + || ffecom_overlap_ (dest_decl, dest_offset, dest_size, + TREE_OPERAND (source_tree, 2), NULL, + scalar_arg); + + + case ADDR_EXPR: + ffecom_tree_canonize_ref_ (&source_decl, &source_offset, + &source_size, + TREE_OPERAND (source_tree, 0)); + break; + + case PARM_DECL: + if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE) + return TRUE; + + source_decl = source_tree; + source_offset = size_zero_node; + source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree))); + break; + + case SAVE_EXPR: + case REFERENCE_EXPR: + case PREDECREMENT_EXPR: + case PREINCREMENT_EXPR: + case POSTDECREMENT_EXPR: + case POSTINCREMENT_EXPR: + case INDIRECT_REF: + case ARRAY_REF: + case CALL_EXPR: + default: + return TRUE; + } + + /* Come here when source_decl, source_offset, and source_size filled + in appropriately. */ + + if (source_decl == NULL_TREE) + return FALSE; /* No decl involved, so no overlap. */ + + if (source_decl != dest_decl) + return FALSE; /* Different decl, no overlap. */ + + if (TREE_CODE (dest_size) == ERROR_MARK) + return TRUE; /* Assignment into entire assumed-size + array? Shouldn't happen.... */ + + t = ffecom_2 (LE_EXPR, integer_type_node, + ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset), + dest_offset, + convert (TREE_TYPE (dest_offset), + dest_size)), + convert (TREE_TYPE (dest_offset), + source_offset)); + + if (integer_onep (t)) + return FALSE; /* Destination precedes source. */ + + if (!scalar_arg + || (source_size == NULL_TREE) + || (TREE_CODE (source_size) == ERROR_MARK) + || integer_zerop (source_size)) + return TRUE; /* No way to tell if dest follows source. */ + + t = ffecom_2 (LE_EXPR, integer_type_node, + ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset), + source_offset, + convert (TREE_TYPE (source_offset), + source_size)), + convert (TREE_TYPE (source_offset), + dest_offset)); + + if (integer_onep (t)) + return FALSE; /* Destination follows source. */ + + 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, + bool scalar_args) +{ + tree arg; + tree dest_decl; + tree dest_offset; + tree dest_size; + + ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size, + dest_tree); + + if (dest_decl == NULL_TREE) + return FALSE; /* Seems unlikely! */ + + /* If the decl cannot be determined reliably, or if its in COMMON + and the callee isn't known to not futz with COMMON via other + means, overlap might happen. */ + + if ((TREE_CODE (dest_decl) == ERROR_MARK) + || ((callee_commons != NULL_TREE) + && TREE_PUBLIC (dest_decl))) + return TRUE; + + for (; args != NULL_TREE; args = TREE_CHAIN (args)) + { + if (((arg = TREE_VALUE (args)) != NULL_TREE) + && ffecom_overlap_ (dest_decl, dest_offset, dest_size, + arg, NULL, scalar_args)) + return TRUE; + } + + 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, char *s) +{ + if (!ffe_is_f2c_library ()) + return build_string (i, s); + + { + char *tmp; + char *p; + char *q; + char space[34]; + tree t; + + if (((size_t) i) > ARRAY_SIZE (space)) + tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i); + else + tmp = &space[0]; + + for (p = s, q = tmp; *p != '\0'; ++p, ++q) + *q = ffesrc_toupper (*p); + *q = '\0'; + + t = build_string (i, tmp); + + if (((size_t) i) > ARRAY_SIZE (space)) + malloc_kill_ks (malloc_pool_image (), tmp, i); + + return t; + } +} + +#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, + ffebld dest, bool *dest_used, tree callee_commons, + bool scalar_args) +{ + tree item; + tree tempvar; + + if (dest_used != NULL) + *dest_used = FALSE; + + if (is_f2c_complex) + { + if ((dest_used == NULL) + || (dest == NULL) + || (ffeinfo_basictype (ffebld_info (dest)) + != FFEINFO_basictypeCOMPLEX) + || (ffeinfo_kindtype (ffebld_info (dest)) != kt) + || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type)) + || ffecom_args_overlapping_ (dest_tree, dest, args, + callee_commons, + scalar_args)) + { + tempvar = ffecom_push_tempvar (ffecom_tree_type + [FFEINFO_basictypeCOMPLEX][kt], + FFETARGET_charactersizeNONE, + -1, TRUE); + } + else + { + *dest_used = TRUE; + tempvar = dest_tree; + type = NULL_TREE; + } + + item + = build_tree_list (NULL_TREE, + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (tempvar)), + tempvar)); + TREE_CHAIN (item) = args; + + item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn, + item, NULL_TREE); + + if (tempvar != dest_tree) + item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar); + } + else + item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn, + args, NULL_TREE); + + if ((type != NULL_TREE) && (TREE_TYPE (item) != type)) + item = ffecom_convert_narrow_ (type, item); + + 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, + tree dest_tree, ffebld dest, bool *dest_used, + tree callee_commons, bool scalar_args) +{ + tree left_tree; + tree right_tree; + tree left_length; + tree right_length; + + ffecom_push_calltemps (); + left_tree = ffecom_arg_ptr_to_expr (left, &left_length); + right_tree = ffecom_arg_ptr_to_expr (right, &right_length); + ffecom_pop_calltemps (); + + left_tree = build_tree_list (NULL_TREE, left_tree); + right_tree = build_tree_list (NULL_TREE, right_tree); + TREE_CHAIN (left_tree) = right_tree; + + if (left_length != NULL_TREE) + { + left_length = build_tree_list (NULL_TREE, left_length); + TREE_CHAIN (right_tree) = left_length; + } + + if (right_length != NULL_TREE) + { + right_length = build_tree_list (NULL_TREE, right_length); + if (left_length != NULL_TREE) + TREE_CHAIN (left_length) = right_length; + else + TREE_CHAIN (right_tree) = right_length; + } + + return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree, + dest_tree, dest, dest_used, callee_commons, + scalar_args); +} +#endif + +/* ffecom_char_args_ -- Return ptr/length args for char subexpression + + tree ptr_arg; + tree length_arg; + ffebld expr; + ffecom_char_args_(&ptr_arg,&length_arg,expr); + + Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF + subexpressions by constructing the appropriate trees for the ptr-to- + character-text and length-of-character-text arguments in a calling + sequence. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_char_args_ (tree *xitem, tree *length, ffebld expr) +{ + tree item; + tree high; + ffetargetCharacter1 val; + + switch (ffebld_op (expr)) + { + case FFEBLD_opCONTER: + val = ffebld_constant_character1 (ffebld_conter (expr)); + *length = build_int_2 (ffetarget_length_character1 (val), 0); + TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; + high = build_int_2 (ffetarget_length_character1 (val), + 0); + TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node; + item = build_string (ffetarget_length_character1 (val), + ffetarget_text_character1 (val)); + TREE_TYPE (item) + = build_type_variant + (build_array_type + (char_type_node, + build_range_type + (ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + high)), + 1, 0); + TREE_CONSTANT (item) = 1; + TREE_STATIC (item) = 1; + item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)), + item); + break; + + case FFEBLD_opSYMTER: + { + ffesymbol s = ffebld_symter (expr); + + item = ffesymbol_hook (s).decl_tree; + if (item == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + item = ffesymbol_hook (s).decl_tree; + } + if (ffesymbol_kind (s) == FFEINFO_kindENTITY) + { + if (ffesymbol_size (s) == FFETARGET_charactersizeNONE) + *length = ffesymbol_hook (s).length_tree; + else + { + *length = build_int_2 (ffesymbol_size (s), 0); + TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; + } + } + else if (item == error_mark_node) + *length = error_mark_node; + else /* FFEINFO_kindFUNCTION: */ + *length = NULL_TREE; + if (!ffesymbol_hook (s).addr + && (item != error_mark_node)) + item = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (item)), + item); + } + break; + + case FFEBLD_opARRAYREF: + { + ffebld dims[FFECOM_dimensionsMAX]; + tree array; + int i; + + ffecom_push_calltemps (); + ffecom_char_args_ (&item, length, ffebld_left (expr)); + ffecom_pop_calltemps (); + + if (item == error_mark_node || *length == error_mark_node) + { + item = *length = error_mark_node; + break; + } + + /* Build up ARRAY_REFs in reverse order (since we're column major + here in Fortran land). */ + + for (i = 0, expr = ffebld_right (expr); + expr != NULL; + expr = ffebld_trail (expr)) + dims[i++] = ffebld_head (expr); + + for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))); + i >= 0; + --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array))) + { + item = ffecom_2 (PLUS_EXPR, build_pointer_type (TREE_TYPE (array)), + item, + size_binop (MULT_EXPR, + size_in_bytes (TREE_TYPE (array)), + size_binop (MINUS_EXPR, + ffecom_expr (dims[i]), + TYPE_MIN_VALUE (TYPE_DOMAIN (array))))); + } + } + break; + + case FFEBLD_opSUBSTR: + { + ffebld start; + ffebld end; + ffebld thing = ffebld_right (expr); + tree start_tree; + tree end_tree; + + assert (ffebld_op (thing) == FFEBLD_opITEM); + start = ffebld_head (thing); + thing = ffebld_trail (thing); + assert (ffebld_trail (thing) == NULL); + end = ffebld_head (thing); + + ffecom_push_calltemps (); + ffecom_char_args_ (&item, length, ffebld_left (expr)); + ffecom_pop_calltemps (); + + if (item == error_mark_node || *length == error_mark_node) + { + item = *length = error_mark_node; + break; + } + + if (start == NULL) + { + if (end == NULL) + ; + else + { + end_tree = convert (ffecom_f2c_ftnlen_type_node, + ffecom_expr (end)); + + if (end_tree == error_mark_node) + { + item = *length = error_mark_node; + break; + } + + *length = end_tree; + } + } + else + { + start_tree = convert (ffecom_f2c_ftnlen_type_node, + ffecom_expr (start)); + + if (start_tree == error_mark_node) + { + item = *length = error_mark_node; + break; + } + + start_tree = ffecom_save_tree (start_tree); + + item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item), + item, + ffecom_2 (MINUS_EXPR, + TREE_TYPE (start_tree), + start_tree, + ffecom_f2c_ftnlen_one_node)); + + if (end == NULL) + { + *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + ffecom_2 (MINUS_EXPR, + ffecom_f2c_ftnlen_type_node, + *length, + start_tree)); + } + else + { + end_tree = convert (ffecom_f2c_ftnlen_type_node, + ffecom_expr (end)); + + if (end_tree == error_mark_node) + { + item = *length = error_mark_node; + break; + } + + *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + ffecom_2 (MINUS_EXPR, + ffecom_f2c_ftnlen_type_node, + end_tree, start_tree)); + } + } + } + break; + + case FFEBLD_opFUNCREF: + { + ffesymbol s = ffebld_symter (ffebld_left (expr)); + tree tempvar; + tree args; + ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr)); + ffecomGfrt ix; + + if (size == FFETARGET_charactersizeNONE) + size = 24; /* ~~~~ Kludge alert! This should someday be fixed. */ + + *length = build_int_2 (size, 0); + TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; + + if (ffeinfo_where (ffebld_info (ffebld_left (expr))) + == FFEINFO_whereINTRINSIC) + { + if (size == 1) + { /* Invocation of an intrinsic returning CHARACTER*1. */ + item = ffecom_expr_intrinsic_ (expr, NULL_TREE, + NULL, NULL); + break; + } + ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr))); + assert (ix != FFECOM_gfrt); + item = ffecom_gfrt_tree_ (ix); + } + else + { + ix = FFECOM_gfrt; + item = ffesymbol_hook (s).decl_tree; + if (item == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + item = ffesymbol_hook (s).decl_tree; + } + if (item == error_mark_node) + { + item = *length = error_mark_node; + break; + } + + if (!ffesymbol_hook (s).addr) + item = ffecom_1_fn (item); + } + + assert (ffecom_pending_calls_ != 0); + tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE); + tempvar = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (tempvar)), + tempvar); + + ffecom_push_calltemps (); + + args = build_tree_list (NULL_TREE, tempvar); + + if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) /* Sfunc args by value. */ + TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr)); + else + { + TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length); + if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC) + { + TREE_CHAIN (TREE_CHAIN (args)) + = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix), + ffebld_right (expr)); + } + else + { + TREE_CHAIN (TREE_CHAIN (args)) + = ffecom_list_ptr_to_expr (ffebld_right (expr)); + } + } + + item = ffecom_3s (CALL_EXPR, + TREE_TYPE (TREE_TYPE (TREE_TYPE (item))), + item, args, NULL_TREE); + item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, + tempvar); + + ffecom_pop_calltemps (); + } + break; + + case FFEBLD_opCONVERT: + + ffecom_push_calltemps (); + ffecom_char_args_ (&item, length, ffebld_left (expr)); + ffecom_pop_calltemps (); + + if (item == error_mark_node || *length == error_mark_node) + { + item = *length = error_mark_node; + break; + } + + if ((ffebld_size_known (ffebld_left (expr)) + == FFETARGET_charactersizeNONE) + || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr)))) + { /* Possible blank-padding needed, copy into + temporary. */ + tree tempvar; + tree args; + tree newlen; + + assert (ffecom_pending_calls_ != 0); + tempvar = ffecom_push_tempvar (char_type_node, + ffebld_size (expr), -1, TRUE); + tempvar = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (tempvar)), + tempvar); + + newlen = build_int_2 (ffebld_size (expr), 0); + TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node; + + args = build_tree_list (NULL_TREE, tempvar); + TREE_CHAIN (args) = build_tree_list (NULL_TREE, item); + TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args))) + = build_tree_list (NULL_TREE, *length); + + item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args); + TREE_SIDE_EFFECTS (item) = 1; + item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item), + tempvar); + *length = newlen; + } + else + { /* Just truncate the length. */ + *length = build_int_2 (ffebld_size (expr), 0); + TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; + } + break; + + default: + assert ("bad op for single char arg expr" == NULL); + item = NULL_TREE; + break; + } + + *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 + can generally overflow the normal sizes as long as the computations + themselves don't overflow. A particular target of the back end + 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) +{ + if (TREE_CODE (type) == ERROR_MARK) + return type; + + if (TYPE_SIZE (type) == NULL_TREE) + return type; + + if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST) + return type; + + if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0) + || (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0)) + || TREE_OVERFLOW (TYPE_SIZE (type))) + { + ffebad_start (FFEBAD_ARRAY_LARGE); + ffebad_string (ffesymbol_text (s)); + ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s)); + ffebad_finish (); + + return error_mark_node; + } + + return type; +} +#endif + +/* Builds a length argument (PARM_DECL). Also wraps type in an array type + where the dimension info is (1:size) where 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) +{ + ffetargetCharacterSize sz = ffesymbol_size (s); + tree highval; + tree tlen; + tree type = *xtype; + + if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) + tlen = NULL_TREE; /* A statement function, no length passed. */ + else + { + if (ffesymbol_where (s) == FFEINFO_whereDUMMY) + tlen = ffecom_get_invented_identifier ("__g77_length_%s", + ffesymbol_text (s), 0); + else + tlen = ffecom_get_invented_identifier ("__g77_%s", + "length", 0); + tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node); +#if BUILT_FOR_270 + DECL_ARTIFICIAL (tlen) = 1; +#endif + } + + if (sz == FFETARGET_charactersizeNONE) + { + assert (tlen != NULL_TREE); + highval = tlen; + } + else + { + highval = build_int_2 (sz, 0); + TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node; + } + + type = build_array_type (type, + build_range_type (ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + highval)); + + *xtype = type; + return tlen; +} + +#endif +/* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs + + ffecomConcatList_ catlist; + ffebld expr; // expr of CHARACTER basictype. + ffetargetCharacterSize max; // max chars to gather or _...NONE if no max + catlist = ffecom_concat_list_gather_(catlist,expr,max); + + 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: /* :::::::::::::::::::: */ + + if (expr == NULL) + return catlist; + + if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max)) + return catlist; /* Don't append any more items. */ + + switch (ffebld_op (expr)) + { + case FFEBLD_opCONTER: + case FFEBLD_opSYMTER: + case FFEBLD_opARRAYREF: + case FFEBLD_opFUNCREF: + case FFEBLD_opSUBSTR: + case FFEBLD_opCONVERT: /* Callers should strip this off beforehand + if they don't need to preserve it. */ + if (catlist.count == catlist.max) + { /* Make a (larger) list. */ + ffebld *newx; + int newmax; + + newmax = (catlist.max == 0) ? 8 : catlist.max * 2; + newx = malloc_new_ks (malloc_pool_image (), "catlist", + newmax * sizeof (newx[0])); + if (catlist.max != 0) + { + memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0])); + malloc_kill_ks (malloc_pool_image (), catlist.exprs, + catlist.max * sizeof (newx[0])); + } + catlist.max = newmax; + catlist.exprs = newx; + } + if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE) + catlist.minlen += sz; + else + ++catlist.minlen; /* Not true for F90; can be 0 length. */ + if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE) + catlist.maxlen = sz; + else + catlist.maxlen += sz; + if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max)) + { /* This item overlaps (or is beyond) the end + of the destination. */ + switch (ffebld_op (expr)) + { + case FFEBLD_opCONTER: + case FFEBLD_opSYMTER: + case FFEBLD_opARRAYREF: + case FFEBLD_opFUNCREF: + case FFEBLD_opSUBSTR: + break; /* ~~Do useful truncations here. */ + + default: + assert ("op changed or inconsistent switches!" == NULL); + break; + } + } + catlist.exprs[catlist.count++] = expr; + return catlist; + + case FFEBLD_opPAREN: + expr = ffebld_left (expr); + goto recurse; /* :::::::::::::::::::: */ + + case FFEBLD_opCONCATENATE: + catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max); + expr = ffebld_right (expr); + goto recurse; /* :::::::::::::::::::: */ + +#if 0 /* Breaks passing small actual arg to larger + dummy arg of sfunc */ + case FFEBLD_opCONVERT: + expr = ffebld_left (expr); + { + ffetargetCharacterSize cmax; + + cmax = catlist.len + ffebld_size_known (expr); + + if ((max == FFETARGET_charactersizeNONE) || (max > cmax)) + max = cmax; + } + goto recurse; /* :::::::::::::::::::: */ +#endif + + case FFEBLD_opANY: + return catlist; + + default: + assert ("bad op in _gather_" == NULL); + return catlist; + } +} + +#endif +/* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs + + ffecomConcatList_ catlist; + ffecom_concat_list_kill_(catlist); + + Anything allocated within the list info is deallocated. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_concat_list_kill_ (ffecomConcatList_ catlist) +{ + if (catlist.max != 0) + malloc_kill_ks (malloc_pool_image (), catlist.exprs, + catlist.max * sizeof (catlist.exprs[0])); +} + +#endif +/* ffecom_concat_list_new_ -- Make list of concatenated string exprs + + ffecomConcatList_ catlist; + ffebld expr; // Root expr of CHARACTER basictype. + ffetargetCharacterSize max; // max chars to gather or _...NONE if no max + catlist = ffecom_concat_list_new_(expr,max); + + 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) +{ + ffecomConcatList_ catlist; + + catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0; + 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, char *aggr_type, ffesymbol member, + tree member_type UNUSED, ffetargetOffset offset) +{ + tree value; + tree decl; + int len; + char *buff; + char space[120]; +#if 0 + tree type_id; + + for (type_id = member_type; + TREE_CODE (type_id) != IDENTIFIER_NODE; + ) + { + switch (TREE_CODE (type_id)) + { + case INTEGER_TYPE: + case REAL_TYPE: + type_id = TYPE_NAME (type_id); + break; + + case ARRAY_TYPE: + case COMPLEX_TYPE: + type_id = TREE_TYPE (type_id); + break; + + default: + assert ("no IDENTIFIER_NODE for type!" == NULL); + type_id = error_mark_node; + break; + } + } +#endif + + if (ffecom_transform_only_dummies_ + || !ffe_is_debug_kludge ()) + return; /* Can't do this yet, maybe later. */ + + len = 60 + + strlen (aggr_type) + + IDENTIFIER_LENGTH (DECL_NAME (aggr)); +#if 0 + + IDENTIFIER_LENGTH (type_id); +#endif + + if (((size_t) len) >= ARRAY_SIZE (space)) + buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1); + else + buff = &space[0]; + + sprintf (&buff[0], "At (%s) `%s' plus %ld bytes", + aggr_type, + IDENTIFIER_POINTER (DECL_NAME (aggr)), + (long int) offset); + + value = build_string (len, buff); + TREE_TYPE (value) + = build_type_variant (build_array_type (char_type_node, + build_range_type + (integer_type_node, + integer_one_node, + build_int_2 (strlen (buff), 0))), + 1, 0); + decl = build_decl (VAR_DECL, + ffecom_get_identifier_ (ffesymbol_text (member)), + TREE_TYPE (value)); + TREE_CONSTANT (decl) = 1; + TREE_STATIC (decl) = 1; + DECL_INITIAL (decl) = error_mark_node; + DECL_IN_SYSTEM_HEADER (decl) = 1; /* Don't let -Wunused complain. */ + decl = start_decl (decl, FALSE); + finish_decl (decl, value, FALSE); + + if (buff != &space[0]) + malloc_kill_ks (malloc_pool_image (), buff, len + 1); +} +#endif + +/* ffecom_do_entry_ -- Do compilation of a particular entrypoint + + ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself + int i; // entry# for this entrypoint (used by master fn) + ffecom_do_entrypoint_(s,i); + + 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) +{ + ffebld item; + tree type; /* Type of function. */ + tree multi_retval; /* Var holding return value (union). */ + tree result; /* Var holding result. */ + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffeglobal g; + ffeglobalType gt; + bool charfunc; /* All entry points return same type + CHARACTER. */ + bool cmplxfunc; /* Use f2c way of returning COMPLEX. */ + bool multi; /* Master fn has multiple return types. */ + bool altreturning = FALSE; /* This entry point has alternate returns. */ + int yes; + + /* c-parse.y indeed does call suspend_momentary and not only ignores the + return value, but also never calls resume_momentary, when starting an + outer function (see "fndef:", "setspecs:", and so on). So g77 does the + same thing. It shouldn't be a problem since start_function calls + temporary_allocation, but it might be necessary. If it causes a problem + here, then maybe there's a bug lurking in gcc. NOTE: This identical + comment appears twice in thist file. */ + + suspend_momentary (); + + ffecom_doing_entry_ = TRUE; /* Don't bother with array dimensions. */ + + switch (ffecom_primary_entry_kind_) + { + case FFEINFO_kindFUNCTION: + + /* Determine actual return type for function. */ + + gt = FFEGLOBAL_typeFUNC; + bt = ffesymbol_basictype (fn); + kt = ffesymbol_kindtype (fn); + if (bt == FFEINFO_basictypeNONE) + { + ffeimplic_establish_symbol (fn); + if (ffesymbol_funcresult (fn) != NULL) + ffeimplic_establish_symbol (ffesymbol_funcresult (fn)); + bt = ffesymbol_basictype (fn); + kt = ffesymbol_kindtype (fn); + } + + if (bt == FFEINFO_basictypeCHARACTER) + charfunc = TRUE, cmplxfunc = FALSE; + else if ((bt == FFEINFO_basictypeCOMPLEX) + && ffesymbol_is_f2c (fn)) + charfunc = FALSE, cmplxfunc = TRUE; + else + charfunc = cmplxfunc = FALSE; + + if (charfunc) + type = ffecom_tree_fun_type_void; + else if (ffesymbol_is_f2c (fn)) + type = ffecom_tree_fun_type[bt][kt]; + else + type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE); + + if ((type == NULL_TREE) + || (TREE_TYPE (type) == NULL_TREE)) + type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */ + + multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE); + break; + + case FFEINFO_kindSUBROUTINE: + gt = FFEGLOBAL_typeSUBR; + bt = FFEINFO_basictypeNONE; + kt = FFEINFO_kindtypeNONE; + if (ffecom_is_altreturning_) + { /* Am _I_ altreturning? */ + for (item = ffesymbol_dummyargs (fn); + item != NULL; + item = ffebld_trail (item)) + { + if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR) + { + altreturning = TRUE; + break; + } + } + if (altreturning) + type = ffecom_tree_subr_type; + else + type = ffecom_tree_fun_type_void; + } + else + type = ffecom_tree_fun_type_void; + charfunc = FALSE; + cmplxfunc = FALSE; + multi = FALSE; + break; + + default: + assert ("say what??" == NULL); + /* Fall through. */ + case FFEINFO_kindANY: + gt = FFEGLOBAL_typeANY; + bt = FFEINFO_basictypeNONE; + kt = FFEINFO_kindtypeNONE; + type = error_mark_node; + charfunc = FALSE; + cmplxfunc = FALSE; + multi = FALSE; + break; + } + + /* build_decl uses the current lineno and input_filename to set the decl + source info. So, I've putzed with ffestd and ffeste code to update that + source info to point to the appropriate statement just before calling + ffecom_do_entrypoint (which calls this fn). */ + + start_function (ffecom_get_external_identifier_ (fn), + type, + 0, /* nested/inline */ + 1); /* TREE_PUBLIC */ + + if (((g = ffesymbol_global (fn)) != NULL) + && ((ffeglobal_type (g) == gt) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) + { + ffeglobal_set_hook (g, current_function_decl); + } + + /* Reset args in master arg list so they get retransitioned. */ + + for (item = ffecom_master_arglist_; + item != NULL; + item = ffebld_trail (item)) + { + ffebld arg; + ffesymbol s; + + arg = ffebld_head (item); + if (ffebld_op (arg) != FFEBLD_opSYMTER) + continue; /* Alternate return or some such thing. */ + s = ffebld_symter (arg); + ffesymbol_hook (s).decl_tree = NULL_TREE; + ffesymbol_hook (s).length_tree = NULL_TREE; + } + + /* Build dummy arg list for this entry point. */ + + yes = suspend_momentary (); + + if (charfunc || cmplxfunc) + { /* Prepend arg for where result goes. */ + tree type; + tree length; + + if (charfunc) + type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt]; + else + type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt]; + + result = ffecom_get_invented_identifier ("__g77_%s", + "result", 0); + + /* Make length arg _and_ enhance type info for CHAR arg itself. */ + + if (charfunc) + length = ffecom_char_enhance_arg_ (&type, fn); + else + length = NULL_TREE; /* Not ref'd if !charfunc. */ + + type = build_pointer_type (type); + result = build_decl (PARM_DECL, result, type); + + push_parm_decl (result); + ffecom_func_result_ = result; + + if (charfunc) + { + push_parm_decl (length); + ffecom_func_length_ = length; + } + } + else + result = DECL_RESULT (current_function_decl); + + ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE); + + resume_momentary (yes); + + store_parm_decls (0); + + ffecom_start_compstmt_ (); + + /* Make local var to hold return type for multi-type master fn. */ + + if (multi) + { + yes = suspend_momentary (); + + multi_retval = ffecom_get_invented_identifier ("__g77_%s", + "multi_retval", 0); + multi_retval = build_decl (VAR_DECL, multi_retval, + ffecom_multi_type_node_); + multi_retval = start_decl (multi_retval, FALSE); + finish_decl (multi_retval, NULL_TREE, FALSE); + + resume_momentary (yes); + } + else + multi_retval = NULL_TREE; /* Not actually ref'd if !multi. */ + + /* Here we emit the actual code for the entry point. */ + + { + ffebld list; + ffebld arg; + ffesymbol s; + tree arglist = NULL_TREE; + tree *plist = &arglist; + tree prepend; + tree call; + tree actarg; + tree master_fn; + + /* Prepare actual arg list based on master arg list. */ + + for (list = ffecom_master_arglist_; + list != NULL; + list = ffebld_trail (list)) + { + arg = ffebld_head (list); + if (ffebld_op (arg) != FFEBLD_opSYMTER) + continue; + s = ffebld_symter (arg); + if (ffesymbol_hook (s).decl_tree == NULL_TREE) + actarg = null_pointer_node; /* We don't have this arg. */ + else + actarg = ffesymbol_hook (s).decl_tree; + *plist = build_tree_list (NULL_TREE, actarg); + plist = &TREE_CHAIN (*plist); + } + + /* This code appends the length arguments for character + variables/arrays. */ + + for (list = ffecom_master_arglist_; + list != NULL; + list = ffebld_trail (list)) + { + arg = ffebld_head (list); + if (ffebld_op (arg) != FFEBLD_opSYMTER) + continue; + s = ffebld_symter (arg); + if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER) + continue; /* Only looking for CHARACTER arguments. */ + if (ffesymbol_kind (s) != FFEINFO_kindENTITY) + continue; /* Only looking for variables and arrays. */ + if (ffesymbol_hook (s).length_tree == NULL_TREE) + actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */ + else + actarg = ffesymbol_hook (s).length_tree; + *plist = build_tree_list (NULL_TREE, actarg); + plist = &TREE_CHAIN (*plist); + } + + /* Prepend character-value return info to actual arg list. */ + + if (charfunc) + { + prepend = build_tree_list (NULL_TREE, ffecom_func_result_); + TREE_CHAIN (prepend) + = build_tree_list (NULL_TREE, ffecom_func_length_); + TREE_CHAIN (TREE_CHAIN (prepend)) = arglist; + arglist = prepend; + } + + /* Prepend multi-type return value to actual arg list. */ + + if (multi) + { + prepend + = build_tree_list (NULL_TREE, + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (multi_retval)), + multi_retval)); + TREE_CHAIN (prepend) = arglist; + arglist = prepend; + } + + /* Prepend my entry-point number to the actual arg list. */ + + prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0)); + TREE_CHAIN (prepend) = arglist; + arglist = prepend; + + /* Build the call to the master function. */ + + master_fn = ffecom_1_fn (ffecom_previous_function_decl_); + call = ffecom_3s (CALL_EXPR, + TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))), + master_fn, arglist, NULL_TREE); + + /* Decide whether the master function is a function or subroutine, and + handle the return value for my entry point. */ + + if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE) + && !altreturning)) + { + expand_expr_stmt (call); + expand_null_return (); + } + else if (multi && cmplxfunc) + { + expand_expr_stmt (call); + result + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))), + result); + result = ffecom_modify (NULL_TREE, result, + ffecom_2 (COMPONENT_REF, TREE_TYPE (result), + multi_retval, + ffecom_multi_fields_[bt][kt])); + expand_expr_stmt (result); + expand_null_return (); + } + else if (multi) + { + expand_expr_stmt (call); + result + = ffecom_modify (NULL_TREE, result, + convert (TREE_TYPE (result), + ffecom_2 (COMPONENT_REF, + ffecom_tree_type[bt][kt], + multi_retval, + ffecom_multi_fields_[bt][kt]))); + expand_return (result); + } + else if (cmplxfunc) + { + result + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))), + result); + result = ffecom_modify (NULL_TREE, result, call); + expand_expr_stmt (result); + expand_null_return (); + } + else + { + result = ffecom_modify (NULL_TREE, + result, + convert (TREE_TYPE (result), + call)); + expand_return (result); + } + + clear_momentary (); + } + + ffecom_end_compstmt_ (); + + finish_function (0); + + ffecom_doing_entry_ = FALSE; +} + +#endif +/* Transform expr into gcc tree with possible destination + + Recursive descent on expr while making corresponding tree nodes and + attaching type info and such. If destination supplied and compatible + 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) +{ + tree item; + tree list; + tree args; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + tree t; + tree tree_type; + tree dt; /* decl_tree for an ffesymbol. */ + ffesymbol s; + enum tree_code code; + + assert (expr != NULL); + + if (dest_used != NULL) + *dest_used = FALSE; + + bt = ffeinfo_basictype (ffebld_info (expr)); + kt = ffeinfo_kindtype (ffebld_info (expr)); + + switch (ffebld_op (expr)) + { + case FFEBLD_opACCTER: + tree_type = ffecom_tree_type[bt][kt]; + { + ffebitCount i; + ffebit bits = ffebld_accter_bits (expr); + ffetargetOffset source_offset = 0; + size_t size; + tree purpose; + + size = ffetype_size (ffeinfo_type (bt, kt)); + + list = item = NULL; + for (;;) + { + ffebldConstantUnion cu; + ffebitCount length; + bool value; + ffebldConstantArray ca = ffebld_accter (expr); + + ffebit_test (bits, source_offset, &value, &length); + if (length == 0) + break; + + if (value) + { + for (i = 0; i < length; ++i) + { + cu = ffebld_constantarray_get (ca, bt, kt, + source_offset + i); + + t = ffecom_constantunion (&cu, bt, kt, tree_type); + + if (i == 0) + purpose = build_int_2 (source_offset, 0); + else + purpose = NULL_TREE; + + if (list == NULL_TREE) + list = item = build_tree_list (purpose, t); + else + { + TREE_CHAIN (item) = build_tree_list (purpose, t); + item = TREE_CHAIN (item); + } + } + } + source_offset += length; + } + } + + item = build_int_2 (ffebld_accter_size (expr), 0); + ffebit_kill (ffebld_accter_bits (expr)); + TREE_TYPE (item) = ffecom_integer_type_node; + item + = build_array_type + (tree_type, + build_range_type (ffecom_integer_type_node, + ffecom_integer_zero_node, + item)); + list = build (CONSTRUCTOR, item, NULL_TREE, list); + TREE_CONSTANT (list) = 1; + TREE_STATIC (list) = 1; + return list; + + case FFEBLD_opARRTER: + tree_type = ffecom_tree_type[bt][kt]; + { + ffetargetOffset i; + + list = item = NULL_TREE; + for (i = 0; i < ffebld_arrter_size (expr); ++i) + { + ffebldConstantUnion cu + = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i); + + t = ffecom_constantunion (&cu, bt, kt, tree_type); + + if (list == NULL_TREE) + list = item = build_tree_list (NULL_TREE, t); + else + { + TREE_CHAIN (item) = build_tree_list (NULL_TREE, t); + item = TREE_CHAIN (item); + } + } + } + + item = build_int_2 (ffebld_arrter_size (expr), 0); + TREE_TYPE (item) = ffecom_integer_type_node; + item + = build_array_type + (tree_type, + build_range_type (ffecom_integer_type_node, + ffecom_integer_one_node, + item)); + list = build (CONSTRUCTOR, item, NULL_TREE, list); + TREE_CONSTANT (list) = 1; + TREE_STATIC (list) = 1; + return list; + + case FFEBLD_opCONTER: + tree_type = ffecom_tree_type[bt][kt]; + item + = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)), + bt, kt, tree_type); + return item; + + case FFEBLD_opSYMTER: + if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE) + || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE)) + return ffecom_ptr_to_expr (expr); /* Same as %REF(intrinsic). */ + s = ffebld_symter (expr); + t = ffesymbol_hook (s).decl_tree; + + if (assignp) + { /* ASSIGN'ed-label expr. */ + if (ffe_is_ugly_assign ()) + { + /* User explicitly wants ASSIGN'ed variables to be at the same + memory address as the variables when used in non-ASSIGN + contexts. That can make old, arcane, non-standard code + work, but don't try to do it when a pointer wouldn't fit + in the normal variable (take other approach, and warn, + instead). */ + + if (t == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + t = ffesymbol_hook (s).decl_tree; + assert (t != NULL_TREE); + } + + if (t == error_mark_node) + return t; + + if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t))) + >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node)))) + { + if (ffesymbol_hook (s).addr) + t = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t); + return t; + } + + if (ffesymbol_hook (s).assign_tree == NULL_TREE) + { + ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling", + FFEBAD_severityWARNING); + ffebad_string (ffesymbol_text (s)); + ffebad_here (0, ffesymbol_where_line (s), + ffesymbol_where_column (s)); + ffebad_finish (); + } + } + + /* Don't use the normal variable's tree for ASSIGN, though mark + it as in the system header (housekeeping). Use an explicit, + specially created sibling that is known to be wide enough + to hold pointers to labels. */ + + if (t != NULL_TREE + && TREE_CODE (t) == VAR_DECL) + DECL_IN_SYSTEM_HEADER (t) = 1; /* Don't let -Wunused complain. */ + + t = ffesymbol_hook (s).assign_tree; + if (t == NULL_TREE) + { + s = ffecom_sym_transform_assign_ (s); + t = ffesymbol_hook (s).assign_tree; + assert (t != NULL_TREE); + } + } + else + { + if (t == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + t = ffesymbol_hook (s).decl_tree; + assert (t != NULL_TREE); + } + if (ffesymbol_hook (s).addr) + t = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t); + } + return t; + + case FFEBLD_opARRAYREF: + { + ffebld dims[FFECOM_dimensionsMAX]; +#if FFECOM_FASTER_ARRAY_REFS + tree array; +#endif + int i; + +#if FFECOM_FASTER_ARRAY_REFS + t = ffecom_ptr_to_expr (ffebld_left (expr)); +#else + t = ffecom_expr (ffebld_left (expr)); +#endif + if (t == error_mark_node) + return t; + + if ((ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING) + && !mark_addressable (t)) + return error_mark_node; /* Make sure non-const ref is to + non-reg. */ + + /* Build up ARRAY_REFs in reverse order (since we're column major + here in Fortran land). */ + + for (i = 0, expr = ffebld_right (expr); + expr != NULL; + expr = ffebld_trail (expr)) + dims[i++] = ffebld_head (expr); + +#if FFECOM_FASTER_ARRAY_REFS + for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))); + i >= 0; + --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array))) + t = ffecom_2 (PLUS_EXPR, + build_pointer_type (TREE_TYPE (array)), + t, + size_binop (MULT_EXPR, + size_in_bytes (TREE_TYPE (array)), + size_binop (MINUS_EXPR, + ffecom_expr (dims[i]), + TYPE_MIN_VALUE (TYPE_DOMAIN (array))))); + t = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), + t); +#else + while (i > 0) + t = ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), + t, + ffecom_expr (dims[--i])); +#endif + + return t; + } + + case FFEBLD_opUPLUS: + tree_type = ffecom_tree_type[bt][kt]; + return ffecom_1 (NOP_EXPR, tree_type, ffecom_expr (ffebld_left (expr))); + + case FFEBLD_opPAREN: /* ~~~Make sure Fortran rules respected here */ + tree_type = ffecom_tree_type[bt][kt]; + return ffecom_1 (NOP_EXPR, tree_type, ffecom_expr (ffebld_left (expr))); + + case FFEBLD_opUMINUS: + tree_type = ffecom_tree_type[bt][kt]; + return ffecom_1 (NEGATE_EXPR, tree_type, + ffecom_expr (ffebld_left (expr))); + + case FFEBLD_opADD: + tree_type = ffecom_tree_type[bt][kt]; + return ffecom_2 (PLUS_EXPR, tree_type, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr))); + break; + + case FFEBLD_opSUBTRACT: + tree_type = ffecom_tree_type[bt][kt]; + return ffecom_2 (MINUS_EXPR, tree_type, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr))); + + case FFEBLD_opMULTIPLY: + tree_type = ffecom_tree_type[bt][kt]; + return ffecom_2 (MULT_EXPR, tree_type, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr))); + + case FFEBLD_opDIVIDE: + tree_type = ffecom_tree_type[bt][kt]; + return + ffecom_tree_divide_ (tree_type, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr)), + dest_tree, dest, dest_used); + + case FFEBLD_opPOWER: + tree_type = ffecom_tree_type[bt][kt]; + { + ffebld left = ffebld_left (expr); + ffebld right = ffebld_right (expr); + ffecomGfrt code; + ffeinfoKindtype rtkt; + + switch (ffeinfo_basictype (ffebld_info (right))) + { + case FFEINFO_basictypeINTEGER: + if (1 || optimize) + { + item = ffecom_expr_power_integer_ (left, right); + if (item != NULL_TREE) + return item; + } + + rtkt = FFEINFO_kindtypeINTEGER1; + switch (ffeinfo_basictype (ffebld_info (left))) + { + case FFEINFO_basictypeINTEGER: + if ((ffeinfo_kindtype (ffebld_info (left)) + == FFEINFO_kindtypeINTEGER4) + || (ffeinfo_kindtype (ffebld_info (right)) + == FFEINFO_kindtypeINTEGER4)) + { + code = FFECOM_gfrtPOW_QQ; + rtkt = FFEINFO_kindtypeINTEGER4; + } + else + code = FFECOM_gfrtPOW_II; + break; + + case FFEINFO_basictypeREAL: + if (ffeinfo_kindtype (ffebld_info (left)) + == FFEINFO_kindtypeREAL1) + code = FFECOM_gfrtPOW_RI; + else + code = FFECOM_gfrtPOW_DI; + break; + + case FFEINFO_basictypeCOMPLEX: + if (ffeinfo_kindtype (ffebld_info (left)) + == FFEINFO_kindtypeREAL1) + code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */ + else + code = FFECOM_gfrtPOW_ZI; /* Overlapping result okay. */ + break; + + default: + assert ("bad pow_*i" == NULL); + code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */ + break; + } + if (ffeinfo_kindtype (ffebld_info (left)) != rtkt) + left = ffeexpr_convert (left, NULL, NULL, + FFEINFO_basictypeINTEGER, + rtkt, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + if (ffeinfo_kindtype (ffebld_info (right)) != rtkt) + right = ffeexpr_convert (right, NULL, NULL, + FFEINFO_basictypeINTEGER, + rtkt, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + case FFEINFO_basictypeREAL: + if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1) + left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL, + FFEINFO_kindtypeREALDOUBLE, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + if (ffeinfo_kindtype (ffebld_info (right)) + == FFEINFO_kindtypeREAL1) + right = ffeexpr_convert (right, NULL, NULL, + FFEINFO_basictypeREAL, + FFEINFO_kindtypeREALDOUBLE, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + code = FFECOM_gfrtPOW_DD; + break; + + case FFEINFO_basictypeCOMPLEX: + if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1) + left = ffeexpr_convert (left, NULL, NULL, + FFEINFO_basictypeCOMPLEX, + FFEINFO_kindtypeREALDOUBLE, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + if (ffeinfo_kindtype (ffebld_info (right)) + == FFEINFO_kindtypeREAL1) + right = ffeexpr_convert (right, NULL, NULL, + FFEINFO_basictypeCOMPLEX, + FFEINFO_kindtypeREALDOUBLE, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + code = FFECOM_gfrtPOW_ZZ; /* Overlapping result okay. */ + break; + + default: + assert ("bad pow_x*" == NULL); + code = FFECOM_gfrtPOW_II; + break; + } + return ffecom_call_binop_ (ffecom_gfrt_tree_ (code), + ffecom_gfrt_kindtype (code), + (ffe_is_f2c_library () + && ffecom_gfrt_complex_[code]), + tree_type, left, right, + dest_tree, dest, dest_used, + NULL_TREE, FALSE); + } + + case FFEBLD_opNOT: + tree_type = ffecom_tree_type[bt][kt]; + switch (bt) + { + case FFEINFO_basictypeLOGICAL: + item + = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr))); + return convert (tree_type, item); + + case FFEINFO_basictypeINTEGER: + return ffecom_1 (BIT_NOT_EXPR, tree_type, + ffecom_expr (ffebld_left (expr))); + + default: + assert ("NOT bad basictype" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; + } + break; + + case FFEBLD_opFUNCREF: + assert (ffeinfo_basictype (ffebld_info (expr)) + != FFEINFO_basictypeCHARACTER); + /* Fall through. */ + case FFEBLD_opSUBRREF: + tree_type = ffecom_tree_type[bt][kt]; + if (ffeinfo_where (ffebld_info (ffebld_left (expr))) + == FFEINFO_whereINTRINSIC) + { /* Invocation of an intrinsic. */ + item = ffecom_expr_intrinsic_ (expr, dest_tree, dest, + dest_used); + return item; + } + s = ffebld_symter (ffebld_left (expr)); + dt = ffesymbol_hook (s).decl_tree; + if (dt == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + dt = ffesymbol_hook (s).decl_tree; + } + if (dt == error_mark_node) + return dt; + + if (ffesymbol_hook (s).addr) + item = dt; + else + item = ffecom_1_fn (dt); + + ffecom_push_calltemps (); + if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) + args = ffecom_list_expr (ffebld_right (expr)); + else + args = ffecom_list_ptr_to_expr (ffebld_right (expr)); + ffecom_pop_calltemps (); + + item = ffecom_call_ (item, kt, + ffesymbol_is_f2c (s) + && (bt == FFEINFO_basictypeCOMPLEX) + && (ffesymbol_where (s) + != FFEINFO_whereCONSTANT), + tree_type, + args, + dest_tree, dest, dest_used, + error_mark_node, FALSE); + TREE_SIDE_EFFECTS (item) = 1; + return item; + + case FFEBLD_opAND: + tree_type = ffecom_tree_type[bt][kt]; + switch (bt) + { + case FFEINFO_basictypeLOGICAL: + item + = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, + ffecom_truth_value (ffecom_expr (ffebld_left (expr))), + ffecom_truth_value (ffecom_expr (ffebld_right (expr)))); + return convert (tree_type, item); + + case FFEINFO_basictypeINTEGER: + return ffecom_2 (BIT_AND_EXPR, tree_type, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr))); + + default: + assert ("AND bad basictype" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; + } + break; + + case FFEBLD_opOR: + tree_type = ffecom_tree_type[bt][kt]; + switch (bt) + { + case FFEINFO_basictypeLOGICAL: + item + = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node, + ffecom_truth_value (ffecom_expr (ffebld_left (expr))), + ffecom_truth_value (ffecom_expr (ffebld_right (expr)))); + return convert (tree_type, item); + + case FFEINFO_basictypeINTEGER: + return ffecom_2 (BIT_IOR_EXPR, tree_type, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr))); + + default: + assert ("OR bad basictype" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; + } + break; + + case FFEBLD_opXOR: + case FFEBLD_opNEQV: + tree_type = ffecom_tree_type[bt][kt]; + switch (bt) + { + case FFEINFO_basictypeLOGICAL: + item + = ffecom_2 (NE_EXPR, integer_type_node, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr))); + return convert (tree_type, ffecom_truth_value (item)); + + case FFEINFO_basictypeINTEGER: + return ffecom_2 (BIT_XOR_EXPR, tree_type, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr))); + + default: + assert ("XOR/NEQV bad basictype" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; + } + break; + + case FFEBLD_opEQV: + tree_type = ffecom_tree_type[bt][kt]; + switch (bt) + { + case FFEINFO_basictypeLOGICAL: + item + = ffecom_2 (EQ_EXPR, integer_type_node, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr))); + return convert (tree_type, ffecom_truth_value (item)); + + case FFEINFO_basictypeINTEGER: + return + ffecom_1 (BIT_NOT_EXPR, tree_type, + ffecom_2 (BIT_XOR_EXPR, tree_type, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr)))); + + default: + assert ("EQV bad basictype" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; + } + break; + + case FFEBLD_opCONVERT: + if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY) + return error_mark_node; + + tree_type = ffecom_tree_type[bt][kt]; + switch (bt) + { + case FFEINFO_basictypeLOGICAL: + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeREAL: + return convert (tree_type, ffecom_expr (ffebld_left (expr))); + + case FFEINFO_basictypeCOMPLEX: + switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) + { + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeLOGICAL: + case FFEINFO_basictypeREAL: + item = ffecom_expr (ffebld_left (expr)); + if (item == error_mark_node) + return error_mark_node; + /* convert() takes care of converting to the subtype first, + at least in gcc-2.7.2. */ + item = convert (tree_type, item); + return item; + + case FFEINFO_basictypeCOMPLEX: + return convert (tree_type, ffecom_expr (ffebld_left (expr))); + + default: + assert ("CONVERT COMPLEX bad basictype" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; + } + break; + + default: + assert ("CONVERT bad basictype" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; + } + break; + + case FFEBLD_opLT: + code = LT_EXPR; + goto relational; /* :::::::::::::::::::: */ + + case FFEBLD_opLE: + code = LE_EXPR; + goto relational; /* :::::::::::::::::::: */ + + case FFEBLD_opEQ: + code = EQ_EXPR; + goto relational; /* :::::::::::::::::::: */ + + case FFEBLD_opNE: + code = NE_EXPR; + goto relational; /* :::::::::::::::::::: */ + + case FFEBLD_opGT: + code = GT_EXPR; + goto relational; /* :::::::::::::::::::: */ + + case FFEBLD_opGE: + code = GE_EXPR; + + relational: /* :::::::::::::::::::: */ + + tree_type = ffecom_tree_type[bt][kt]; + switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) + { + case FFEINFO_basictypeLOGICAL: + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeREAL: + item = ffecom_2 (code, integer_type_node, + ffecom_expr (ffebld_left (expr)), + ffecom_expr (ffebld_right (expr))); + return convert (tree_type, item); + + case FFEINFO_basictypeCOMPLEX: + assert (code == EQ_EXPR || code == NE_EXPR); + { + tree real_type; + tree arg1 = ffecom_expr (ffebld_left (expr)); + tree arg2 = ffecom_expr (ffebld_right (expr)); + + if (arg1 == error_mark_node || arg2 == error_mark_node) + return error_mark_node; + + arg1 = ffecom_save_tree (arg1); + arg2 = ffecom_save_tree (arg2); + + if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE) + { + real_type = TREE_TYPE (TREE_TYPE (arg1)); + assert (real_type == TREE_TYPE (TREE_TYPE (arg2))); + } + else + { + real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1))); + assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2)))); + } + + item + = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, + ffecom_2 (EQ_EXPR, integer_type_node, + ffecom_1 (REALPART_EXPR, real_type, arg1), + ffecom_1 (REALPART_EXPR, real_type, arg2)), + ffecom_2 (EQ_EXPR, integer_type_node, + ffecom_1 (IMAGPART_EXPR, real_type, arg1), + ffecom_1 (IMAGPART_EXPR, real_type, + arg2))); + if (code == EQ_EXPR) + item = ffecom_truth_value (item); + else + item = ffecom_truth_value_invert (item); + return convert (tree_type, item); + } + + case FFEINFO_basictypeCHARACTER: + ffecom_push_calltemps (); /* Even though we might not call. */ + + { + ffebld left = ffebld_left (expr); + ffebld right = ffebld_right (expr); + tree left_tree; + tree right_tree; + tree left_length; + tree right_length; + + /* f2c run-time functions do the implicit blank-padding for us, + so we don't usually have to implement blank-padding ourselves. + (The exception is when we pass an argument to a separately + compiled statement function -- if we know the arg is not the + same length as the dummy, we must truncate or extend it. If + we "inline" statement functions, that necessity goes away as + well.) + + Strip off the CONVERT operators that blank-pad. (Truncation by + CONVERT shouldn't happen here, but it can happen in + assignments.) */ + + while (ffebld_op (left) == FFEBLD_opCONVERT) + left = ffebld_left (left); + while (ffebld_op (right) == FFEBLD_opCONVERT) + right = ffebld_left (right); + + left_tree = ffecom_arg_ptr_to_expr (left, &left_length); + right_tree = ffecom_arg_ptr_to_expr (right, &right_length); + + if (left_tree == error_mark_node || left_length == error_mark_node + || right_tree == error_mark_node + || right_length == error_mark_node) + { + ffecom_pop_calltemps (); + return error_mark_node; + } + + if ((ffebld_size_known (left) == 1) + && (ffebld_size_known (right) == 1)) + { + left_tree + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))), + left_tree); + right_tree + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))), + right_tree); + + item + = ffecom_2 (code, integer_type_node, + ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))), + left_tree, + integer_one_node), + ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))), + right_tree, + integer_one_node)); + } + else + { + item = build_tree_list (NULL_TREE, left_tree); + TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree); + TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE, + left_length); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))) + = build_tree_list (NULL_TREE, right_length); + item = ffecom_call_gfrt (FFECOM_gfrtCMP, item); + item = ffecom_2 (code, integer_type_node, + item, + convert (TREE_TYPE (item), + integer_zero_node)); + } + item = convert (tree_type, item); + } + + ffecom_pop_calltemps (); + return item; + + default: + assert ("relational bad basictype" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; + } + break; + + case FFEBLD_opPERCENT_LOC: + tree_type = ffecom_tree_type[bt][kt]; + item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list); + return convert (tree_type, item); + + case FFEBLD_opITEM: + case FFEBLD_opSTAR: + case FFEBLD_opBOUNDS: + case FFEBLD_opREPEAT: + case FFEBLD_opLABTER: + case FFEBLD_opLABTOK: + case FFEBLD_opIMPDO: + case FFEBLD_opCONCATENATE: + case FFEBLD_opSUBSTR: + default: + assert ("bad op" == NULL); + /* Fall through. */ + case FFEBLD_opANY: + return error_mark_node; + } + +#if 1 + assert ("didn't think anything got here anymore!!" == NULL); +#else + switch (ffebld_arity (expr)) + { + case 2: + TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr)); + TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr)); + if (TREE_OPERAND (item, 0) == error_mark_node + || TREE_OPERAND (item, 1) == error_mark_node) + return error_mark_node; + break; + + case 1: + TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr)); + if (TREE_OPERAND (item, 0) == error_mark_node) + return error_mark_node; + break; + + default: + break; + } + + return fold (item); +#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) +{ + tree expr_tree; + tree saved_expr1; /* For those who need it. */ + tree saved_expr2; /* For those who need it. */ + ffeinfoBasictype bt; + ffeinfoKindtype kt; + tree tree_type; + tree arg1_type; + tree real_type; /* REAL type corresponding to COMPLEX. */ + tree tempvar; + ffebld list = ffebld_right (expr); /* List of (some) args. */ + ffebld arg1; /* For handy reference. */ + ffebld arg2; + ffebld arg3; + ffeintrinImp codegen_imp; + ffecomGfrt gfrt; + + assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER); + + if (dest_used != NULL) + *dest_used = FALSE; + + bt = ffeinfo_basictype (ffebld_info (expr)); + kt = ffeinfo_kindtype (ffebld_info (expr)); + tree_type = ffecom_tree_type[bt][kt]; + + if (list != NULL) + { + arg1 = ffebld_head (list); + if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY) + return error_mark_node; + if ((list = ffebld_trail (list)) != NULL) + { + arg2 = ffebld_head (list); + if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY) + return error_mark_node; + if ((list = ffebld_trail (list)) != NULL) + { + arg3 = ffebld_head (list); + if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY) + return error_mark_node; + } + else + arg3 = NULL; + } + else + arg2 = arg3 = NULL; + } + else + arg1 = arg2 = arg3 = NULL; + + /* ends up at the opITEM of the 3rd arg, or NULL if there are < 3 + args. This is used by the MAX/MIN expansions. */ + + if (arg1 != NULL) + arg1_type = ffecom_tree_type + [ffeinfo_basictype (ffebld_info (arg1))] + [ffeinfo_kindtype (ffebld_info (arg1))]; + else + arg1_type = NULL_TREE; /* Really not needed, but might catch bugs + here. */ + + /* There are several ways for each of the cases in the following switch + statements to exit (from simplest to use to most complicated): + + break; (when expr_tree == NULL) + + A standard call is made to the specific intrinsic just as if it had been + passed in as a dummy procedure and called as any old procedure. This + method can produce slower code but in some cases it's the easiest way for + now. However, if a (presumably faster) direct call is available, + that is used, so this is the easiest way in many more cases now. + + gfrt = FFECOM_gfrtWHATEVER; + break; + + gfrt contains the gfrt index of a library function to call, passing the + argument(s) by value rather than by reference. Used when a more + careful choice of library function is needed than that provided + by the vanilla `break;'. + + return expr_tree; + + The expr_tree has been completely set up and is ready to be returned + as is. No further actions are taken. Use this when the tree is not + in the simple form for one of the arity_n labels. */ + + /* For info on how the switch statement cases were written, see the files + enclosed in comments below the switch statement. */ + + codegen_imp = ffebld_symter_implementation (ffebld_left (expr)); + gfrt = ffeintrin_gfrt_direct (codegen_imp); + if (gfrt == FFECOM_gfrt) + gfrt = ffeintrin_gfrt_indirect (codegen_imp); + + switch (codegen_imp) + { + case FFEINTRIN_impABS: + case FFEINTRIN_impCABS: + case FFEINTRIN_impCDABS: + case FFEINTRIN_impDABS: + case FFEINTRIN_impIABS: + if (ffeinfo_basictype (ffebld_info (arg1)) + == FFEINFO_basictypeCOMPLEX) + { + if (kt == FFEINFO_kindtypeREAL1) + gfrt = FFECOM_gfrtCABS; + else if (kt == FFEINFO_kindtypeREAL2) + gfrt = FFECOM_gfrtCDABS; + break; + } + return ffecom_1 (ABS_EXPR, tree_type, + convert (tree_type, ffecom_expr (arg1))); + + case FFEINTRIN_impACOS: + case FFEINTRIN_impDACOS: + break; + + case FFEINTRIN_impAIMAG: + case FFEINTRIN_impDIMAG: + case FFEINTRIN_impIMAGPART: + if (TREE_CODE (arg1_type) == COMPLEX_TYPE) + arg1_type = TREE_TYPE (arg1_type); + else + arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type)); + + return + convert (tree_type, + ffecom_1 (IMAGPART_EXPR, arg1_type, + ffecom_expr (arg1))); + + case FFEINTRIN_impAINT: + case FFEINTRIN_impDINT: +#if 0 /* ~~ someday implement FIX_TRUNC_EXPR + yielding same type as arg */ + return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1)); +#else /* in the meantime, must use floor to avoid range problems with ints */ + /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */ + saved_expr1 = ffecom_save_tree (ffecom_expr (arg1)); + return + convert (tree_type, + ffecom_3 (COND_EXPR, double_type_node, + ffecom_truth_value + (ffecom_2 (GE_EXPR, integer_type_node, + saved_expr1, + convert (arg1_type, + ffecom_float_zero_))), + ffecom_call_gfrt (FFECOM_gfrtL_FLOOR, + build_tree_list (NULL_TREE, + convert (double_type_node, + saved_expr1))), + ffecom_1 (NEGATE_EXPR, double_type_node, + ffecom_call_gfrt (FFECOM_gfrtL_FLOOR, + build_tree_list (NULL_TREE, + convert (double_type_node, + ffecom_1 (NEGATE_EXPR, + arg1_type, + saved_expr1)))) + )) + ); +#endif + + case FFEINTRIN_impANINT: + case FFEINTRIN_impDNINT: +#if 0 /* This way of doing it won't handle real + numbers of large magnitudes. */ + saved_expr1 = ffecom_save_tree (ffecom_expr (arg1)); + expr_tree = convert (tree_type, + convert (integer_type_node, + ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (GE_EXPR, + integer_type_node, + saved_expr1, + ffecom_float_zero_)), + ffecom_2 (PLUS_EXPR, + tree_type, + saved_expr1, + ffecom_float_half_), + ffecom_2 (MINUS_EXPR, + tree_type, + saved_expr1, + ffecom_float_half_)))); + return expr_tree; +#else /* So we instead call floor. */ + /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */ + saved_expr1 = ffecom_save_tree (ffecom_expr (arg1)); + return + convert (tree_type, + ffecom_3 (COND_EXPR, double_type_node, + ffecom_truth_value + (ffecom_2 (GE_EXPR, integer_type_node, + saved_expr1, + convert (arg1_type, + ffecom_float_zero_))), + ffecom_call_gfrt (FFECOM_gfrtL_FLOOR, + build_tree_list (NULL_TREE, + convert (double_type_node, + ffecom_2 (PLUS_EXPR, + arg1_type, + saved_expr1, + convert (arg1_type, + ffecom_float_half_))))), + ffecom_1 (NEGATE_EXPR, double_type_node, + ffecom_call_gfrt (FFECOM_gfrtL_FLOOR, + build_tree_list (NULL_TREE, + convert (double_type_node, + ffecom_2 (MINUS_EXPR, + arg1_type, + convert (arg1_type, + ffecom_float_half_), + saved_expr1))))) + ) + ); +#endif + + case FFEINTRIN_impASIN: + case FFEINTRIN_impDASIN: + case FFEINTRIN_impATAN: + case FFEINTRIN_impDATAN: + case FFEINTRIN_impATAN2: + case FFEINTRIN_impDATAN2: + break; + + case FFEINTRIN_impCHAR: + case FFEINTRIN_impACHAR: + assert (ffecom_pending_calls_ != 0); + tempvar = ffecom_push_tempvar (char_type_node, + 1, -1, TRUE); + { + tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar))); + + expr_tree = ffecom_modify (tmv, + ffecom_2 (ARRAY_REF, tmv, tempvar, + integer_one_node), + convert (tmv, ffecom_expr (arg1))); + } + expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), + expr_tree, + tempvar); + expr_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (expr_tree)), + expr_tree); + return expr_tree; + + case FFEINTRIN_impCMPLX: + case FFEINTRIN_impDCMPLX: + if (arg2 == NULL) + return + convert (tree_type, ffecom_expr (arg1)); + + real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt]; + return + ffecom_2 (COMPLEX_EXPR, tree_type, + convert (real_type, ffecom_expr (arg1)), + convert (real_type, + ffecom_expr (arg2))); + + case FFEINTRIN_impCOMPLEX: + return + ffecom_2 (COMPLEX_EXPR, tree_type, + ffecom_expr (arg1), + ffecom_expr (arg2)); + + case FFEINTRIN_impCONJG: + case FFEINTRIN_impDCONJG: + { + tree arg1_tree; + + real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt]; + arg1_tree = ffecom_save_tree (ffecom_expr (arg1)); + return + ffecom_2 (COMPLEX_EXPR, tree_type, + ffecom_1 (REALPART_EXPR, real_type, arg1_tree), + ffecom_1 (NEGATE_EXPR, real_type, + ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree))); + } + + case FFEINTRIN_impCOS: + case FFEINTRIN_impCCOS: + case FFEINTRIN_impCDCOS: + case FFEINTRIN_impDCOS: + if (bt == FFEINFO_basictypeCOMPLEX) + { + if (kt == FFEINFO_kindtypeREAL1) + gfrt = FFECOM_gfrtCCOS; /* Overlapping result okay. */ + else if (kt == FFEINFO_kindtypeREAL2) + gfrt = FFECOM_gfrtCDCOS; /* Overlapping result okay. */ + } + break; + + case FFEINTRIN_impCOSH: + case FFEINTRIN_impDCOSH: + break; + + case FFEINTRIN_impDBLE: + case FFEINTRIN_impDFLOAT: + case FFEINTRIN_impDREAL: + case FFEINTRIN_impFLOAT: + case FFEINTRIN_impIDINT: + case FFEINTRIN_impIFIX: + case FFEINTRIN_impINT2: + case FFEINTRIN_impINT8: + case FFEINTRIN_impINT: + case FFEINTRIN_impLONG: + case FFEINTRIN_impREAL: + case FFEINTRIN_impSHORT: + case FFEINTRIN_impSNGL: + return convert (tree_type, ffecom_expr (arg1)); + + case FFEINTRIN_impDIM: + case FFEINTRIN_impDDIM: + case FFEINTRIN_impIDIM: + saved_expr1 = ffecom_save_tree (convert (tree_type, + ffecom_expr (arg1))); + saved_expr2 = ffecom_save_tree (convert (tree_type, + ffecom_expr (arg2))); + return + ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (GT_EXPR, integer_type_node, + saved_expr1, + saved_expr2)), + ffecom_2 (MINUS_EXPR, tree_type, + saved_expr1, + saved_expr2), + convert (tree_type, ffecom_float_zero_)); + + case FFEINTRIN_impDPROD: + return + ffecom_2 (MULT_EXPR, tree_type, + convert (tree_type, ffecom_expr (arg1)), + convert (tree_type, ffecom_expr (arg2))); + + case FFEINTRIN_impEXP: + case FFEINTRIN_impCDEXP: + case FFEINTRIN_impCEXP: + case FFEINTRIN_impDEXP: + if (bt == FFEINFO_basictypeCOMPLEX) + { + if (kt == FFEINFO_kindtypeREAL1) + gfrt = FFECOM_gfrtCEXP; /* Overlapping result okay. */ + else if (kt == FFEINFO_kindtypeREAL2) + gfrt = FFECOM_gfrtCDEXP; /* Overlapping result okay. */ + } + break; + + case FFEINTRIN_impICHAR: + case FFEINTRIN_impIACHAR: +#if 0 /* The simple approach. */ + ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1); + expr_tree + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))), + expr_tree); + expr_tree + = ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))), + expr_tree, + integer_one_node); + return convert (tree_type, expr_tree); +#else /* The more interesting (and more optimal) approach. */ + expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1); + expr_tree = ffecom_3 (COND_EXPR, tree_type, + saved_expr1, + expr_tree, + convert (tree_type, integer_zero_node)); + return expr_tree; +#endif + + case FFEINTRIN_impINDEX: + break; + + case FFEINTRIN_impLEN: +#if 0 + break; /* The simple approach. */ +#else + return ffecom_intrinsic_len_ (arg1); /* The more optimal approach. */ +#endif + + case FFEINTRIN_impLGE: + case FFEINTRIN_impLGT: + case FFEINTRIN_impLLE: + case FFEINTRIN_impLLT: + break; + + case FFEINTRIN_impLOG: + case FFEINTRIN_impALOG: + case FFEINTRIN_impCDLOG: + case FFEINTRIN_impCLOG: + case FFEINTRIN_impDLOG: + if (bt == FFEINFO_basictypeCOMPLEX) + { + if (kt == FFEINFO_kindtypeREAL1) + gfrt = FFECOM_gfrtCLOG; /* Overlapping result okay. */ + else if (kt == FFEINFO_kindtypeREAL2) + gfrt = FFECOM_gfrtCDLOG; /* Overlapping result okay. */ + } + break; + + case FFEINTRIN_impLOG10: + case FFEINTRIN_impALOG10: + case FFEINTRIN_impDLOG10: + if (gfrt != FFECOM_gfrt) + break; /* Already picked one, stick with it. */ + + if (kt == FFEINFO_kindtypeREAL1) + gfrt = FFECOM_gfrtALOG10; + else if (kt == FFEINFO_kindtypeREAL2) + gfrt = FFECOM_gfrtDLOG10; + break; + + case FFEINTRIN_impMAX: + case FFEINTRIN_impAMAX0: + case FFEINTRIN_impAMAX1: + case FFEINTRIN_impDMAX1: + case FFEINTRIN_impMAX0: + case FFEINTRIN_impMAX1: + if (bt != ffeinfo_basictype (ffebld_info (arg1))) + arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr)); + else + arg1_type = tree_type; + expr_tree = ffecom_2 (MAX_EXPR, arg1_type, + convert (arg1_type, ffecom_expr (arg1)), + convert (arg1_type, ffecom_expr (arg2))); + for (; list != NULL; list = ffebld_trail (list)) + { + if ((ffebld_head (list) == NULL) + || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY)) + continue; + expr_tree = ffecom_2 (MAX_EXPR, arg1_type, + expr_tree, + convert (arg1_type, + ffecom_expr (ffebld_head (list)))); + } + return convert (tree_type, expr_tree); + + case FFEINTRIN_impMIN: + case FFEINTRIN_impAMIN0: + case FFEINTRIN_impAMIN1: + case FFEINTRIN_impDMIN1: + case FFEINTRIN_impMIN0: + case FFEINTRIN_impMIN1: + if (bt != ffeinfo_basictype (ffebld_info (arg1))) + arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr)); + else + arg1_type = tree_type; + expr_tree = ffecom_2 (MIN_EXPR, arg1_type, + convert (arg1_type, ffecom_expr (arg1)), + convert (arg1_type, ffecom_expr (arg2))); + for (; list != NULL; list = ffebld_trail (list)) + { + if ((ffebld_head (list) == NULL) + || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY)) + continue; + expr_tree = ffecom_2 (MIN_EXPR, arg1_type, + expr_tree, + convert (arg1_type, + ffecom_expr (ffebld_head (list)))); + } + return convert (tree_type, expr_tree); + + case FFEINTRIN_impMOD: + case FFEINTRIN_impAMOD: + case FFEINTRIN_impDMOD: + if (bt != FFEINFO_basictypeREAL) + return ffecom_2 (TRUNC_MOD_EXPR, tree_type, + convert (tree_type, ffecom_expr (arg1)), + convert (tree_type, ffecom_expr (arg2))); + + if (kt == FFEINFO_kindtypeREAL1) + gfrt = FFECOM_gfrtAMOD; + else if (kt == FFEINFO_kindtypeREAL2) + gfrt = FFECOM_gfrtDMOD; + break; + + case FFEINTRIN_impNINT: + case FFEINTRIN_impIDNINT: +#if 0 /* ~~ ideally FIX_ROUND_EXPR would be + implemented, but it ain't yet */ + return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1)); +#else + /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */ + saved_expr1 = ffecom_save_tree (ffecom_expr (arg1)); + return + convert (ffecom_integer_type_node, + ffecom_3 (COND_EXPR, arg1_type, + ffecom_truth_value + (ffecom_2 (GE_EXPR, integer_type_node, + saved_expr1, + convert (arg1_type, + ffecom_float_zero_))), + ffecom_2 (PLUS_EXPR, arg1_type, + saved_expr1, + convert (arg1_type, + ffecom_float_half_)), + ffecom_2 (MINUS_EXPR, arg1_type, + saved_expr1, + convert (arg1_type, + ffecom_float_half_)))); +#endif + + case FFEINTRIN_impSIGN: + case FFEINTRIN_impDSIGN: + case FFEINTRIN_impISIGN: + { + tree arg2_tree = ffecom_expr (arg2); + + saved_expr1 + = ffecom_save_tree + (ffecom_1 (ABS_EXPR, tree_type, + convert (tree_type, + ffecom_expr (arg1)))); + expr_tree + = ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (GE_EXPR, integer_type_node, + arg2_tree, + convert (TREE_TYPE (arg2_tree), + integer_zero_node))), + saved_expr1, + ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1)); + /* Make sure SAVE_EXPRs get referenced early enough. */ + expr_tree + = ffecom_2 (COMPOUND_EXPR, tree_type, + convert (void_type_node, saved_expr1), + expr_tree); + } + return expr_tree; + + case FFEINTRIN_impSIN: + case FFEINTRIN_impCDSIN: + case FFEINTRIN_impCSIN: + case FFEINTRIN_impDSIN: + if (bt == FFEINFO_basictypeCOMPLEX) + { + if (kt == FFEINFO_kindtypeREAL1) + gfrt = FFECOM_gfrtCSIN; /* Overlapping result okay. */ + else if (kt == FFEINFO_kindtypeREAL2) + gfrt = FFECOM_gfrtCDSIN; /* Overlapping result okay. */ + } + break; + + case FFEINTRIN_impSINH: + case FFEINTRIN_impDSINH: + break; + + case FFEINTRIN_impSQRT: + case FFEINTRIN_impCDSQRT: + case FFEINTRIN_impCSQRT: + case FFEINTRIN_impDSQRT: + if (bt == FFEINFO_basictypeCOMPLEX) + { + if (kt == FFEINFO_kindtypeREAL1) + gfrt = FFECOM_gfrtCSQRT; /* Overlapping result okay. */ + else if (kt == FFEINFO_kindtypeREAL2) + gfrt = FFECOM_gfrtCDSQRT; /* Overlapping result okay. */ + } + break; + + case FFEINTRIN_impTAN: + case FFEINTRIN_impDTAN: + case FFEINTRIN_impTANH: + case FFEINTRIN_impDTANH: + break; + + case FFEINTRIN_impREALPART: + if (TREE_CODE (arg1_type) == COMPLEX_TYPE) + arg1_type = TREE_TYPE (arg1_type); + else + arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type)); + + return + convert (tree_type, + ffecom_1 (REALPART_EXPR, arg1_type, + ffecom_expr (arg1))); + + case FFEINTRIN_impIAND: + case FFEINTRIN_impAND: + return ffecom_2 (BIT_AND_EXPR, tree_type, + convert (tree_type, + ffecom_expr (arg1)), + convert (tree_type, + ffecom_expr (arg2))); + + case FFEINTRIN_impIOR: + case FFEINTRIN_impOR: + return ffecom_2 (BIT_IOR_EXPR, tree_type, + convert (tree_type, + ffecom_expr (arg1)), + convert (tree_type, + ffecom_expr (arg2))); + + case FFEINTRIN_impIEOR: + case FFEINTRIN_impXOR: + return ffecom_2 (BIT_XOR_EXPR, tree_type, + convert (tree_type, + ffecom_expr (arg1)), + convert (tree_type, + ffecom_expr (arg2))); + + case FFEINTRIN_impLSHIFT: + return ffecom_2 (LSHIFT_EXPR, tree_type, + ffecom_expr (arg1), + convert (integer_type_node, + ffecom_expr (arg2))); + + case FFEINTRIN_impRSHIFT: + return ffecom_2 (RSHIFT_EXPR, tree_type, + ffecom_expr (arg1), + convert (integer_type_node, + ffecom_expr (arg2))); + + case FFEINTRIN_impNOT: + return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1)); + + case FFEINTRIN_impBIT_SIZE: + return convert (tree_type, TYPE_SIZE (arg1_type)); + + case FFEINTRIN_impBTEST: + { + ffetargetLogical1 true; + ffetargetLogical1 false; + tree true_tree; + tree false_tree; + + ffetarget_logical1 (&true, TRUE); + ffetarget_logical1 (&false, FALSE); + if (true == 1) + true_tree = convert (tree_type, integer_one_node); + else + true_tree = convert (tree_type, build_int_2 (true, 0)); + if (false == 0) + false_tree = convert (tree_type, integer_zero_node); + else + false_tree = convert (tree_type, build_int_2 (false, 0)); + + return + ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (EQ_EXPR, integer_type_node, + ffecom_2 (BIT_AND_EXPR, arg1_type, + ffecom_expr (arg1), + ffecom_2 (LSHIFT_EXPR, arg1_type, + convert (arg1_type, + integer_one_node), + convert (integer_type_node, + ffecom_expr (arg2)))), + convert (arg1_type, + integer_zero_node))), + false_tree, + true_tree); + } + + case FFEINTRIN_impIBCLR: + return + ffecom_2 (BIT_AND_EXPR, tree_type, + ffecom_expr (arg1), + ffecom_1 (BIT_NOT_EXPR, tree_type, + ffecom_2 (LSHIFT_EXPR, tree_type, + convert (tree_type, + integer_one_node), + convert (integer_type_node, + ffecom_expr (arg2))))); + + case FFEINTRIN_impIBITS: + { + tree arg3_tree = ffecom_save_tree (convert (integer_type_node, + ffecom_expr (arg3))); + tree uns_type + = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; + + expr_tree + = ffecom_2 (BIT_AND_EXPR, tree_type, + ffecom_2 (RSHIFT_EXPR, tree_type, + ffecom_expr (arg1), + convert (integer_type_node, + ffecom_expr (arg2))), + convert (tree_type, + ffecom_2 (RSHIFT_EXPR, uns_type, + ffecom_1 (BIT_NOT_EXPR, + uns_type, + convert (uns_type, + integer_zero_node)), + ffecom_2 (MINUS_EXPR, + integer_type_node, + TYPE_SIZE (uns_type), + arg3_tree)))); +#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH + expr_tree + = ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (NE_EXPR, integer_type_node, + arg3_tree, + integer_zero_node)), + expr_tree, + convert (tree_type, integer_zero_node)); +#endif + } + return expr_tree; + + case FFEINTRIN_impIBSET: + return + ffecom_2 (BIT_IOR_EXPR, tree_type, + ffecom_expr (arg1), + ffecom_2 (LSHIFT_EXPR, tree_type, + convert (tree_type, integer_one_node), + convert (integer_type_node, + ffecom_expr (arg2)))); + + case FFEINTRIN_impISHFT: + { + tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1)); + tree arg2_tree = ffecom_save_tree (convert (integer_type_node, + ffecom_expr (arg2))); + tree uns_type + = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; + + expr_tree + = ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (GE_EXPR, integer_type_node, + arg2_tree, + integer_zero_node)), + ffecom_2 (LSHIFT_EXPR, tree_type, + arg1_tree, + arg2_tree), + convert (tree_type, + ffecom_2 (RSHIFT_EXPR, uns_type, + convert (uns_type, arg1_tree), + ffecom_1 (NEGATE_EXPR, + integer_type_node, + arg2_tree)))); +#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH + expr_tree + = ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (NE_EXPR, integer_type_node, + arg2_tree, + TYPE_SIZE (uns_type))), + expr_tree, + convert (tree_type, integer_zero_node)); +#endif + /* Make sure SAVE_EXPRs get referenced early enough. */ + expr_tree + = ffecom_2 (COMPOUND_EXPR, tree_type, + convert (void_type_node, arg1_tree), + ffecom_2 (COMPOUND_EXPR, tree_type, + convert (void_type_node, arg2_tree), + expr_tree)); + } + return expr_tree; + + case FFEINTRIN_impISHFTC: + { + tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1)); + tree arg2_tree = ffecom_save_tree (convert (integer_type_node, + ffecom_expr (arg2))); + tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type) + : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3))); + tree shift_neg; + tree shift_pos; + tree mask_arg1; + tree masked_arg1; + tree uns_type + = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; + + mask_arg1 + = ffecom_2 (LSHIFT_EXPR, tree_type, + ffecom_1 (BIT_NOT_EXPR, tree_type, + convert (tree_type, integer_zero_node)), + arg3_tree); +#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH + mask_arg1 + = ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (NE_EXPR, integer_type_node, + arg3_tree, + TYPE_SIZE (uns_type))), + mask_arg1, + convert (tree_type, integer_zero_node)); +#endif + mask_arg1 = ffecom_save_tree (mask_arg1); + masked_arg1 + = ffecom_2 (BIT_AND_EXPR, tree_type, + arg1_tree, + ffecom_1 (BIT_NOT_EXPR, tree_type, + mask_arg1)); + masked_arg1 = ffecom_save_tree (masked_arg1); + shift_neg + = ffecom_2 (BIT_IOR_EXPR, tree_type, + convert (tree_type, + ffecom_2 (RSHIFT_EXPR, uns_type, + convert (uns_type, masked_arg1), + ffecom_1 (NEGATE_EXPR, + integer_type_node, + arg2_tree))), + ffecom_2 (LSHIFT_EXPR, tree_type, + arg1_tree, + ffecom_2 (PLUS_EXPR, integer_type_node, + arg2_tree, + arg3_tree))); + shift_pos + = ffecom_2 (BIT_IOR_EXPR, tree_type, + ffecom_2 (LSHIFT_EXPR, tree_type, + arg1_tree, + arg2_tree), + convert (tree_type, + ffecom_2 (RSHIFT_EXPR, uns_type, + convert (uns_type, masked_arg1), + ffecom_2 (MINUS_EXPR, + integer_type_node, + arg3_tree, + arg2_tree)))); + expr_tree + = ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (LT_EXPR, integer_type_node, + arg2_tree, + integer_zero_node)), + shift_neg, + shift_pos); + expr_tree + = ffecom_2 (BIT_IOR_EXPR, tree_type, + ffecom_2 (BIT_AND_EXPR, tree_type, + mask_arg1, + arg1_tree), + ffecom_2 (BIT_AND_EXPR, tree_type, + ffecom_1 (BIT_NOT_EXPR, tree_type, + mask_arg1), + expr_tree)); + expr_tree + = ffecom_3 (COND_EXPR, tree_type, + ffecom_truth_value + (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node, + ffecom_2 (EQ_EXPR, integer_type_node, + ffecom_1 (ABS_EXPR, + integer_type_node, + arg2_tree), + arg3_tree), + ffecom_2 (EQ_EXPR, integer_type_node, + arg2_tree, + integer_zero_node))), + arg1_tree, + expr_tree); + /* Make sure SAVE_EXPRs get referenced early enough. */ + expr_tree + = ffecom_2 (COMPOUND_EXPR, tree_type, + convert (void_type_node, arg1_tree), + ffecom_2 (COMPOUND_EXPR, tree_type, + convert (void_type_node, arg2_tree), + ffecom_2 (COMPOUND_EXPR, tree_type, + convert (void_type_node, + mask_arg1), + ffecom_2 (COMPOUND_EXPR, tree_type, + convert (void_type_node, + masked_arg1), + expr_tree)))); + expr_tree + = ffecom_2 (COMPOUND_EXPR, tree_type, + convert (void_type_node, + arg3_tree), + expr_tree); + } + return expr_tree; + + case FFEINTRIN_impLOC: + { + tree arg1_tree = ffecom_expr (arg1); + + expr_tree + = convert (tree_type, + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg1_tree)), + arg1_tree)); + } + return expr_tree; + + case FFEINTRIN_impMVBITS: + { + tree arg1_tree; + tree arg2_tree; + tree arg3_tree; + ffebld arg4 = ffebld_head (ffebld_trail (list)); + tree arg4_tree; + tree arg4_type; + ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list))); + tree arg5_tree; + tree prep_arg1; + tree prep_arg4; + tree arg5_plus_arg3; + + ffecom_push_calltemps (); + + arg2_tree = convert (integer_type_node, + ffecom_expr (arg2)); + arg3_tree = ffecom_save_tree (convert (integer_type_node, + ffecom_expr (arg3))); + arg4_tree = ffecom_expr_rw (arg4); + arg4_type = TREE_TYPE (arg4_tree); + + arg1_tree = ffecom_save_tree (convert (arg4_type, + ffecom_expr (arg1))); + + arg5_tree = ffecom_save_tree (convert (integer_type_node, + ffecom_expr (arg5))); + + ffecom_pop_calltemps (); + + prep_arg1 + = ffecom_2 (LSHIFT_EXPR, arg4_type, + ffecom_2 (BIT_AND_EXPR, arg4_type, + ffecom_2 (RSHIFT_EXPR, arg4_type, + arg1_tree, + arg2_tree), + ffecom_1 (BIT_NOT_EXPR, arg4_type, + ffecom_2 (LSHIFT_EXPR, arg4_type, + ffecom_1 (BIT_NOT_EXPR, + arg4_type, + convert + (arg4_type, + integer_zero_node)), + arg3_tree))), + arg5_tree); + arg5_plus_arg3 + = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type, + arg5_tree, + arg3_tree)); + prep_arg4 + = ffecom_2 (LSHIFT_EXPR, arg4_type, + ffecom_1 (BIT_NOT_EXPR, arg4_type, + convert (arg4_type, + integer_zero_node)), + arg5_plus_arg3); +#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH + prep_arg4 + = ffecom_3 (COND_EXPR, arg4_type, + ffecom_truth_value + (ffecom_2 (NE_EXPR, integer_type_node, + arg5_plus_arg3, + convert (TREE_TYPE (arg5_plus_arg3), + TYPE_SIZE (arg4_type)))), + prep_arg4, + convert (arg4_type, integer_zero_node)); +#endif + prep_arg4 + = ffecom_2 (BIT_AND_EXPR, arg4_type, + arg4_tree, + ffecom_2 (BIT_IOR_EXPR, arg4_type, + prep_arg4, + ffecom_1 (BIT_NOT_EXPR, arg4_type, + ffecom_2 (LSHIFT_EXPR, arg4_type, + ffecom_1 (BIT_NOT_EXPR, + arg4_type, + convert + (arg4_type, + integer_zero_node)), + arg5_tree)))); + prep_arg1 + = ffecom_2 (BIT_IOR_EXPR, arg4_type, + prep_arg1, + prep_arg4); +#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH + prep_arg1 + = ffecom_3 (COND_EXPR, arg4_type, + ffecom_truth_value + (ffecom_2 (NE_EXPR, integer_type_node, + arg3_tree, + convert (TREE_TYPE (arg3_tree), + integer_zero_node))), + prep_arg1, + arg4_tree); + prep_arg1 + = ffecom_3 (COND_EXPR, arg4_type, + ffecom_truth_value + (ffecom_2 (NE_EXPR, integer_type_node, + arg3_tree, + convert (TREE_TYPE (arg3_tree), + TYPE_SIZE (arg4_type)))), + prep_arg1, + arg1_tree); +#endif + expr_tree + = ffecom_2s (MODIFY_EXPR, void_type_node, + arg4_tree, + prep_arg1); + /* Make sure SAVE_EXPRs get referenced early enough. */ + expr_tree + = ffecom_2 (COMPOUND_EXPR, void_type_node, + arg1_tree, + ffecom_2 (COMPOUND_EXPR, void_type_node, + arg3_tree, + ffecom_2 (COMPOUND_EXPR, void_type_node, + arg5_tree, + ffecom_2 (COMPOUND_EXPR, void_type_node, + arg5_plus_arg3, + expr_tree)))); + expr_tree + = ffecom_2 (COMPOUND_EXPR, void_type_node, + arg4_tree, + expr_tree); + + } + return expr_tree; + + case FFEINTRIN_impDERF: + case FFEINTRIN_impERF: + case FFEINTRIN_impDERFC: + case FFEINTRIN_impERFC: + break; + + case FFEINTRIN_impIARGC: + /* extern int xargc; i__1 = xargc - 1; */ + expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_), + ffecom_tree_xargc_, + convert (TREE_TYPE (ffecom_tree_xargc_), + integer_one_node)); + return expr_tree; + + case FFEINTRIN_impSIGNAL_func: + case FFEINTRIN_impSIGNAL_subr: + { + tree arg1_tree; + tree arg2_tree; + tree arg3_tree; + + ffecom_push_calltemps (); + + arg1_tree = convert (ffecom_f2c_integer_type_node, + ffecom_expr (arg1)); + arg1_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg1_tree)), + arg1_tree); + + /* Pass procedure as a pointer to it, anything else by value. */ + if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY) + arg2_tree = convert (integer_type_node, ffecom_expr (arg2)); + else + arg2_tree = ffecom_ptr_to_expr (arg2); + arg2_tree = convert (TREE_TYPE (null_pointer_node), + arg2_tree); + + if (arg3 != NULL) + arg3_tree = ffecom_expr_rw (arg3); + else + arg3_tree = NULL_TREE; + + ffecom_pop_calltemps (); + + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + arg2_tree = build_tree_list (NULL_TREE, arg2_tree); + TREE_CHAIN (arg1_tree) = arg2_tree; + + expr_tree + = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ? + NULL_TREE : + tree_type), + arg1_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + + if (arg3_tree != NULL_TREE) + expr_tree + = ffecom_modify (NULL_TREE, arg3_tree, + convert (TREE_TYPE (arg3_tree), + expr_tree)); + } + return expr_tree; + + case FFEINTRIN_impALARM: + { + tree arg1_tree; + tree arg2_tree; + tree arg3_tree; + + ffecom_push_calltemps (); + + arg1_tree = convert (ffecom_f2c_integer_type_node, + ffecom_expr (arg1)); + arg1_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg1_tree)), + arg1_tree); + + /* Pass procedure as a pointer to it, anything else by value. */ + if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY) + arg2_tree = convert (integer_type_node, ffecom_expr (arg2)); + else + arg2_tree = ffecom_ptr_to_expr (arg2); + arg2_tree = convert (TREE_TYPE (null_pointer_node), + arg2_tree); + + if (arg3 != NULL) + arg3_tree = ffecom_expr_rw (arg3); + else + arg3_tree = NULL_TREE; + + ffecom_pop_calltemps (); + + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + arg2_tree = build_tree_list (NULL_TREE, arg2_tree); + TREE_CHAIN (arg1_tree) = arg2_tree; + + expr_tree + = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + arg1_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + + if (arg3_tree != NULL_TREE) + expr_tree + = ffecom_modify (NULL_TREE, arg3_tree, + convert (TREE_TYPE (arg3_tree), + expr_tree)); + } + return expr_tree; + + case FFEINTRIN_impCHDIR_subr: + case FFEINTRIN_impFDATE_subr: + case FFEINTRIN_impFGET_subr: + case FFEINTRIN_impFPUT_subr: + case FFEINTRIN_impGETCWD_subr: + case FFEINTRIN_impHOSTNM_subr: + case FFEINTRIN_impSYSTEM_subr: + case FFEINTRIN_impUNLINK_subr: + { + tree arg1_len = integer_zero_node; + tree arg1_tree; + tree arg2_tree; + + ffecom_push_calltemps (); + + arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len); + + if (arg2 != NULL) + arg2_tree = ffecom_expr_rw (arg2); + else + arg2_tree = NULL_TREE; + + ffecom_pop_calltemps (); + + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + arg1_len = build_tree_list (NULL_TREE, arg1_len); + TREE_CHAIN (arg1_tree) = arg1_len; + + expr_tree + = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + arg1_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + + if (arg2_tree != NULL_TREE) + expr_tree + = ffecom_modify (NULL_TREE, arg2_tree, + convert (TREE_TYPE (arg2_tree), + expr_tree)); + } + return expr_tree; + + case FFEINTRIN_impEXIT: + if (arg1 != NULL) + break; + + expr_tree = build_tree_list (NULL_TREE, + ffecom_1 (ADDR_EXPR, + build_pointer_type + (ffecom_integer_type_node), + integer_zero_node)); + + return + ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + void_type_node, + expr_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + + case FFEINTRIN_impFLUSH: + if (arg1 == NULL) + gfrt = FFECOM_gfrtFLUSH; + else + gfrt = FFECOM_gfrtFLUSH1; + break; + + case FFEINTRIN_impCHMOD_subr: + case FFEINTRIN_impLINK_subr: + case FFEINTRIN_impRENAME_subr: + case FFEINTRIN_impSYMLNK_subr: + { + tree arg1_len = integer_zero_node; + tree arg1_tree; + tree arg2_len = integer_zero_node; + tree arg2_tree; + tree arg3_tree; + + ffecom_push_calltemps (); + + arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len); + arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len); + if (arg3 != NULL) + arg3_tree = ffecom_expr_rw (arg3); + else + arg3_tree = NULL_TREE; + + ffecom_pop_calltemps (); + + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + arg1_len = build_tree_list (NULL_TREE, arg1_len); + arg2_tree = build_tree_list (NULL_TREE, arg2_tree); + arg2_len = build_tree_list (NULL_TREE, arg2_len); + TREE_CHAIN (arg1_tree) = arg2_tree; + TREE_CHAIN (arg2_tree) = arg1_len; + TREE_CHAIN (arg1_len) = arg2_len; + expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + arg1_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + if (arg3_tree != NULL_TREE) + expr_tree = ffecom_modify (NULL_TREE, arg3_tree, + convert (TREE_TYPE (arg3_tree), + expr_tree)); + } + return expr_tree; + + case FFEINTRIN_impLSTAT_subr: + case FFEINTRIN_impSTAT_subr: + { + tree arg1_len = integer_zero_node; + tree arg1_tree; + tree arg2_tree; + tree arg3_tree; + + ffecom_push_calltemps (); + + arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len); + + arg2_tree = ffecom_ptr_to_expr (arg2); + + if (arg3 != NULL) + arg3_tree = ffecom_expr_rw (arg3); + else + arg3_tree = NULL_TREE; + + ffecom_pop_calltemps (); + + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + arg1_len = build_tree_list (NULL_TREE, arg1_len); + arg2_tree = build_tree_list (NULL_TREE, arg2_tree); + TREE_CHAIN (arg1_tree) = arg2_tree; + TREE_CHAIN (arg2_tree) = arg1_len; + expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + arg1_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + if (arg3_tree != NULL_TREE) + expr_tree = ffecom_modify (NULL_TREE, arg3_tree, + convert (TREE_TYPE (arg3_tree), + expr_tree)); + } + return expr_tree; + + case FFEINTRIN_impFGETC_subr: + case FFEINTRIN_impFPUTC_subr: + { + tree arg1_tree; + tree arg2_tree; + tree arg2_len = integer_zero_node; + tree arg3_tree; + + ffecom_push_calltemps (); + + arg1_tree = convert (ffecom_f2c_integer_type_node, + ffecom_expr (arg1)); + arg1_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg1_tree)), + arg1_tree); + + arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len); + arg3_tree = ffecom_expr_rw (arg3); + + ffecom_pop_calltemps (); + + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + arg2_tree = build_tree_list (NULL_TREE, arg2_tree); + arg2_len = build_tree_list (NULL_TREE, arg2_len); + TREE_CHAIN (arg1_tree) = arg2_tree; + TREE_CHAIN (arg2_tree) = arg2_len; + + expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + arg1_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + expr_tree = ffecom_modify (NULL_TREE, arg3_tree, + convert (TREE_TYPE (arg3_tree), + expr_tree)); + } + return expr_tree; + + case FFEINTRIN_impFSTAT_subr: + { + tree arg1_tree; + tree arg2_tree; + tree arg3_tree; + + ffecom_push_calltemps (); + + arg1_tree = convert (ffecom_f2c_integer_type_node, + ffecom_expr (arg1)); + arg1_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg1_tree)), + arg1_tree); + + arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node, + ffecom_ptr_to_expr (arg2)); + + if (arg3 == NULL) + arg3_tree = NULL_TREE; + else + arg3_tree = ffecom_expr_rw (arg3); + + ffecom_pop_calltemps (); + + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + arg2_tree = build_tree_list (NULL_TREE, arg2_tree); + TREE_CHAIN (arg1_tree) = arg2_tree; + expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + arg1_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + if (arg3_tree != NULL_TREE) { + expr_tree = ffecom_modify (NULL_TREE, arg3_tree, + convert (TREE_TYPE (arg3_tree), + expr_tree)); + } + } + return expr_tree; + + case FFEINTRIN_impKILL_subr: + { + tree arg1_tree; + tree arg2_tree; + tree arg3_tree; + + ffecom_push_calltemps (); + + arg1_tree = convert (ffecom_f2c_integer_type_node, + ffecom_expr (arg1)); + arg1_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg1_tree)), + arg1_tree); + + arg2_tree = convert (ffecom_f2c_integer_type_node, + ffecom_expr (arg2)); + arg2_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg2_tree)), + arg2_tree); + + if (arg3 == NULL) + arg3_tree = NULL_TREE; + else + arg3_tree = ffecom_expr_rw (arg3); + + ffecom_pop_calltemps (); + + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + arg2_tree = build_tree_list (NULL_TREE, arg2_tree); + TREE_CHAIN (arg1_tree) = arg2_tree; + expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + arg1_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + if (arg3_tree != NULL_TREE) { + expr_tree = ffecom_modify (NULL_TREE, arg3_tree, + convert (TREE_TYPE (arg3_tree), + expr_tree)); + } + } + return expr_tree; + + case FFEINTRIN_impCTIME_subr: + case FFEINTRIN_impTTYNAM_subr: + { + tree arg1_len = integer_zero_node; + tree arg1_tree; + tree arg2_tree; + + ffecom_push_calltemps (); + + arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len); + + arg2_tree = convert (((gfrt == FFEINTRIN_impCTIME_subr) ? + ffecom_f2c_longint_type_node : + ffecom_f2c_integer_type_node), + ffecom_expr (arg2)); + arg2_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg2_tree)), + arg2_tree); + + ffecom_pop_calltemps (); + + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + arg1_len = build_tree_list (NULL_TREE, arg1_len); + arg2_tree = build_tree_list (NULL_TREE, arg2_tree); + TREE_CHAIN (arg1_len) = arg2_tree; + TREE_CHAIN (arg1_tree) = arg1_len; + + expr_tree + = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + arg1_tree, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + } + return expr_tree; + + case FFEINTRIN_impIRAND: + case FFEINTRIN_impRAND: + /* Arg defaults to 0 (normal random case) */ + { + tree arg1_tree; + + if (arg1 == NULL) + arg1_tree = ffecom_integer_zero_node; + else + arg1_tree = ffecom_expr (arg1); + arg1_tree = convert (ffecom_f2c_integer_type_node, + arg1_tree); + arg1_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg1_tree)), + arg1_tree); + arg1_tree = build_tree_list (NULL_TREE, arg1_tree); + + expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + ((codegen_imp == FFEINTRIN_impIRAND) ? + ffecom_f2c_integer_type_node : + ffecom_f2c_doublereal_type_node), + arg1_tree, + dest_tree, dest, dest_used, + NULL_TREE, TRUE); + } + return expr_tree; + + case FFEINTRIN_impFTELL_subr: + case FFEINTRIN_impUMASK_subr: + { + tree arg1_tree; + tree arg2_tree; + + ffecom_push_calltemps (); + + arg1_tree = convert (ffecom_f2c_integer_type_node, + ffecom_expr (arg1)); + arg1_tree = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (arg1_tree)), + arg1_tree); + + if (arg2 == NULL) + arg2_tree = NULL_TREE; + else + arg2_tree = ffecom_expr_rw (arg2); + + ffecom_pop_calltemps (); + + expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + build_tree_list (NULL_TREE, arg1_tree), + NULL_TREE, NULL, NULL, NULL_TREE, + TRUE); + if (arg2_tree != NULL_TREE) { + expr_tree = ffecom_modify (NULL_TREE, arg2_tree, + convert (TREE_TYPE (arg2_tree), + expr_tree)); + } + } + return expr_tree; + + case FFEINTRIN_impCPU_TIME: + case FFEINTRIN_impSECOND_subr: + { + tree arg1_tree; + + ffecom_push_calltemps (); + + arg1_tree = ffecom_expr_rw (arg1); + + ffecom_pop_calltemps (); + + expr_tree + = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + NULL_TREE, + NULL_TREE, NULL, NULL, NULL_TREE, TRUE); + + expr_tree + = ffecom_modify (NULL_TREE, arg1_tree, + convert (TREE_TYPE (arg1_tree), + expr_tree)); + } + return expr_tree; + + case FFEINTRIN_impDTIME_subr: + case FFEINTRIN_impETIME_subr: + { + tree arg1_tree; + tree arg2_tree; + + ffecom_push_calltemps (); + + arg1_tree = ffecom_expr_rw (arg1); + + arg2_tree = ffecom_ptr_to_expr (arg2); + + ffecom_pop_calltemps (); + + expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt), + ffecom_gfrt_kindtype (gfrt), + FALSE, + NULL_TREE, + build_tree_list (NULL_TREE, arg2_tree), + NULL_TREE, NULL, NULL, NULL_TREE, + TRUE); + expr_tree = ffecom_modify (NULL_TREE, arg1_tree, + convert (TREE_TYPE (arg1_tree), + expr_tree)); + } + return expr_tree; + + /* Straightforward calls of libf2c routines: */ + case FFEINTRIN_impABORT: + case FFEINTRIN_impACCESS: + case FFEINTRIN_impBESJ0: + case FFEINTRIN_impBESJ1: + case FFEINTRIN_impBESJN: + case FFEINTRIN_impBESY0: + case FFEINTRIN_impBESY1: + case FFEINTRIN_impBESYN: + case FFEINTRIN_impCHDIR_func: + case FFEINTRIN_impCHMOD_func: + case FFEINTRIN_impDATE: + case FFEINTRIN_impDBESJ0: + case FFEINTRIN_impDBESJ1: + case FFEINTRIN_impDBESJN: + case FFEINTRIN_impDBESY0: + case FFEINTRIN_impDBESY1: + case FFEINTRIN_impDBESYN: + case FFEINTRIN_impDTIME_func: + case FFEINTRIN_impETIME_func: + case FFEINTRIN_impFGETC_func: + case FFEINTRIN_impFGET_func: + case FFEINTRIN_impFNUM: + case FFEINTRIN_impFPUTC_func: + case FFEINTRIN_impFPUT_func: + case FFEINTRIN_impFSEEK: + case FFEINTRIN_impFSTAT_func: + case FFEINTRIN_impFTELL_func: + case FFEINTRIN_impGERROR: + case FFEINTRIN_impGETARG: + case FFEINTRIN_impGETCWD_func: + case FFEINTRIN_impGETENV: + case FFEINTRIN_impGETGID: + case FFEINTRIN_impGETLOG: + case FFEINTRIN_impGETPID: + case FFEINTRIN_impGETUID: + case FFEINTRIN_impGMTIME: + case FFEINTRIN_impHOSTNM_func: + case FFEINTRIN_impIDATE_unix: + case FFEINTRIN_impIDATE_vxt: + case FFEINTRIN_impIERRNO: + case FFEINTRIN_impISATTY: + case FFEINTRIN_impITIME: + case FFEINTRIN_impKILL_func: + case FFEINTRIN_impLINK_func: + case FFEINTRIN_impLNBLNK: + case FFEINTRIN_impLSTAT_func: + case FFEINTRIN_impLTIME: + case FFEINTRIN_impMCLOCK8: + case FFEINTRIN_impMCLOCK: + case FFEINTRIN_impPERROR: + case FFEINTRIN_impRENAME_func: + case FFEINTRIN_impSECNDS: + case FFEINTRIN_impSECOND_func: + case FFEINTRIN_impSLEEP: + case FFEINTRIN_impSRAND: + case FFEINTRIN_impSTAT_func: + case FFEINTRIN_impSYMLNK_func: + case FFEINTRIN_impSYSTEM_CLOCK: + case FFEINTRIN_impSYSTEM_func: + case FFEINTRIN_impTIME8: + case FFEINTRIN_impTIME_unix: + case FFEINTRIN_impTIME_vxt: + case FFEINTRIN_impUMASK_func: + case FFEINTRIN_impUNLINK_func: + break; + + case FFEINTRIN_impCTIME_func: /* CHARACTER functions not handled here. */ + case FFEINTRIN_impFDATE_func: /* CHARACTER functions not handled here. */ + case FFEINTRIN_impTTYNAM_func: /* CHARACTER functions not handled here. */ + case FFEINTRIN_impNONE: + case FFEINTRIN_imp: /* Hush up gcc warning. */ + fprintf (stderr, "No %s implementation.\n", + ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr)))); + assert ("unimplemented intrinsic" == NULL); + return error_mark_node; + } + + assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */ + + ffecom_push_calltemps (); + expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt), + ffebld_right (expr)); + ffecom_pop_calltemps (); + + return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt), + (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]), + tree_type, + expr_tree, dest_tree, dest, dest_used, + NULL_TREE, TRUE); + + /**INDENT* (Do not reformat this comment even with -fca option.) + Data-gathering files: Given the source file listed below, compiled with + f2c I obtained the output file listed after that, and from the output + file I derived the above code. + +-------- (begin input file to f2c) + implicit none + character*10 A1,A2 + complex C1,C2 + integer I1,I2 + real R1,R2 + double precision D1,D2 +C + call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2) +c / + call fooI(I1/I2) + call fooR(R1/I1) + call fooD(D1/I1) + call fooC(C1/I1) + call fooR(R1/R2) + call fooD(R1/D1) + call fooD(D1/D2) + call fooD(D1/R1) + call fooC(C1/C2) + call fooC(C1/R1) + call fooZ(C1/D1) +c ** + call fooI(I1**I2) + call fooR(R1**I1) + call fooD(D1**I1) + call fooC(C1**I1) + call fooR(R1**R2) + call fooD(R1**D1) + call fooD(D1**D2) + call fooD(D1**R1) + call fooC(C1**C2) + call fooC(C1**R1) + call fooZ(C1**D1) +c FFEINTRIN_impABS + call fooR(ABS(R1)) +c FFEINTRIN_impACOS + call fooR(ACOS(R1)) +c FFEINTRIN_impAIMAG + call fooR(AIMAG(C1)) +c FFEINTRIN_impAINT + call fooR(AINT(R1)) +c FFEINTRIN_impALOG + call fooR(ALOG(R1)) +c FFEINTRIN_impALOG10 + call fooR(ALOG10(R1)) +c FFEINTRIN_impAMAX0 + call fooR(AMAX0(I1,I2)) +c FFEINTRIN_impAMAX1 + call fooR(AMAX1(R1,R2)) +c FFEINTRIN_impAMIN0 + call fooR(AMIN0(I1,I2)) +c FFEINTRIN_impAMIN1 + call fooR(AMIN1(R1,R2)) +c FFEINTRIN_impAMOD + call fooR(AMOD(R1,R2)) +c FFEINTRIN_impANINT + call fooR(ANINT(R1)) +c FFEINTRIN_impASIN + call fooR(ASIN(R1)) +c FFEINTRIN_impATAN + call fooR(ATAN(R1)) +c FFEINTRIN_impATAN2 + call fooR(ATAN2(R1,R2)) +c FFEINTRIN_impCABS + call fooR(CABS(C1)) +c FFEINTRIN_impCCOS + call fooC(CCOS(C1)) +c FFEINTRIN_impCEXP + call fooC(CEXP(C1)) +c FFEINTRIN_impCHAR + call fooA(CHAR(I1)) +c FFEINTRIN_impCLOG + call fooC(CLOG(C1)) +c FFEINTRIN_impCONJG + call fooC(CONJG(C1)) +c FFEINTRIN_impCOS + call fooR(COS(R1)) +c FFEINTRIN_impCOSH + call fooR(COSH(R1)) +c FFEINTRIN_impCSIN + call fooC(CSIN(C1)) +c FFEINTRIN_impCSQRT + call fooC(CSQRT(C1)) +c FFEINTRIN_impDABS + call fooD(DABS(D1)) +c FFEINTRIN_impDACOS + call fooD(DACOS(D1)) +c FFEINTRIN_impDASIN + call fooD(DASIN(D1)) +c FFEINTRIN_impDATAN + call fooD(DATAN(D1)) +c FFEINTRIN_impDATAN2 + call fooD(DATAN2(D1,D2)) +c FFEINTRIN_impDCOS + call fooD(DCOS(D1)) +c FFEINTRIN_impDCOSH + call fooD(DCOSH(D1)) +c FFEINTRIN_impDDIM + call fooD(DDIM(D1,D2)) +c FFEINTRIN_impDEXP + call fooD(DEXP(D1)) +c FFEINTRIN_impDIM + call fooR(DIM(R1,R2)) +c FFEINTRIN_impDINT + call fooD(DINT(D1)) +c FFEINTRIN_impDLOG + call fooD(DLOG(D1)) +c FFEINTRIN_impDLOG10 + call fooD(DLOG10(D1)) +c FFEINTRIN_impDMAX1 + call fooD(DMAX1(D1,D2)) +c FFEINTRIN_impDMIN1 + call fooD(DMIN1(D1,D2)) +c FFEINTRIN_impDMOD + call fooD(DMOD(D1,D2)) +c FFEINTRIN_impDNINT + call fooD(DNINT(D1)) +c FFEINTRIN_impDPROD + call fooD(DPROD(R1,R2)) +c FFEINTRIN_impDSIGN + call fooD(DSIGN(D1,D2)) +c FFEINTRIN_impDSIN + call fooD(DSIN(D1)) +c FFEINTRIN_impDSINH + call fooD(DSINH(D1)) +c FFEINTRIN_impDSQRT + call fooD(DSQRT(D1)) +c FFEINTRIN_impDTAN + call fooD(DTAN(D1)) +c FFEINTRIN_impDTANH + call fooD(DTANH(D1)) +c FFEINTRIN_impEXP + call fooR(EXP(R1)) +c FFEINTRIN_impIABS + call fooI(IABS(I1)) +c FFEINTRIN_impICHAR + call fooI(ICHAR(A1)) +c FFEINTRIN_impIDIM + call fooI(IDIM(I1,I2)) +c FFEINTRIN_impIDNINT + call fooI(IDNINT(D1)) +c FFEINTRIN_impINDEX + call fooI(INDEX(A1,A2)) +c FFEINTRIN_impISIGN + call fooI(ISIGN(I1,I2)) +c FFEINTRIN_impLEN + call fooI(LEN(A1)) +c FFEINTRIN_impLGE + call fooL(LGE(A1,A2)) +c FFEINTRIN_impLGT + call fooL(LGT(A1,A2)) +c FFEINTRIN_impLLE + call fooL(LLE(A1,A2)) +c FFEINTRIN_impLLT + call fooL(LLT(A1,A2)) +c FFEINTRIN_impMAX0 + call fooI(MAX0(I1,I2)) +c FFEINTRIN_impMAX1 + call fooI(MAX1(R1,R2)) +c FFEINTRIN_impMIN0 + call fooI(MIN0(I1,I2)) +c FFEINTRIN_impMIN1 + call fooI(MIN1(R1,R2)) +c FFEINTRIN_impMOD + call fooI(MOD(I1,I2)) +c FFEINTRIN_impNINT + call fooI(NINT(R1)) +c FFEINTRIN_impSIGN + call fooR(SIGN(R1,R2)) +c FFEINTRIN_impSIN + call fooR(SIN(R1)) +c FFEINTRIN_impSINH + call fooR(SINH(R1)) +c FFEINTRIN_impSQRT + call fooR(SQRT(R1)) +c FFEINTRIN_impTAN + call fooR(TAN(R1)) +c FFEINTRIN_impTANH + call fooR(TANH(R1)) +c FFEINTRIN_imp_CMPLX_C + call fooC(cmplx(C1,C2)) +c FFEINTRIN_imp_CMPLX_D + call fooZ(cmplx(D1,D2)) +c FFEINTRIN_imp_CMPLX_I + call fooC(cmplx(I1,I2)) +c FFEINTRIN_imp_CMPLX_R + call fooC(cmplx(R1,R2)) +c FFEINTRIN_imp_DBLE_C + call fooD(dble(C1)) +c FFEINTRIN_imp_DBLE_D + call fooD(dble(D1)) +c FFEINTRIN_imp_DBLE_I + call fooD(dble(I1)) +c FFEINTRIN_imp_DBLE_R + call fooD(dble(R1)) +c FFEINTRIN_imp_INT_C + call fooI(int(C1)) +c FFEINTRIN_imp_INT_D + call fooI(int(D1)) +c FFEINTRIN_imp_INT_I + call fooI(int(I1)) +c FFEINTRIN_imp_INT_R + call fooI(int(R1)) +c FFEINTRIN_imp_REAL_C + call fooR(real(C1)) +c FFEINTRIN_imp_REAL_D + call fooR(real(D1)) +c FFEINTRIN_imp_REAL_I + call fooR(real(I1)) +c FFEINTRIN_imp_REAL_R + call fooR(real(R1)) +c +c FFEINTRIN_imp_INT_D: +c +c FFEINTRIN_specIDINT + call fooI(IDINT(D1)) +c +c FFEINTRIN_imp_INT_R: +c +c FFEINTRIN_specIFIX + call fooI(IFIX(R1)) +c FFEINTRIN_specINT + call fooI(INT(R1)) +c +c FFEINTRIN_imp_REAL_D: +c +c FFEINTRIN_specSNGL + call fooR(SNGL(D1)) +c +c FFEINTRIN_imp_REAL_I: +c +c FFEINTRIN_specFLOAT + call fooR(FLOAT(I1)) +c FFEINTRIN_specREAL + call fooR(REAL(I1)) +c + end +-------- (end input file to f2c) + +-------- (begin output from providing above input file as input to: +-------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \ +-------- -e "s:^#.*$::g"') + +// -- translated by f2c (version 19950223). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +// + + +// f2c.h -- Standard Fortran to C header file // + +/// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) // + + + + +// F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems // +// we assume short, float are OK // +typedef long int // long int // integer; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef long int // long int // logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; +// typedef long long longint; // // system-dependent // + + + + +// Extern is for use with -E // + + + + +// I/O stuff // + + + + + + + + +typedef long int // int or long int // flag; +typedef long int // int or long int // ftnlen; +typedef long int // int or long int // ftnint; + + +//external read, write// +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +//internal read, write// +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +//open// +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +//close// +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +//rewind, backspace, endfile// +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +// inquire // +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; //parameters in standard's order// + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + + + +union Multitype { // for multiple entry points // + integer1 g; + shortint h; + integer i; + // longint j; // + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +typedef long Long; // No longer used; formerly in Namelist // + +struct Vardesc { // for Namelist // + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + + + + + + + + +// procedure parameter types for -A and -C++ // + + + + +typedef int // Unknown procedure type // (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef // Complex // void (*C_fp)(); +typedef // Double Complex // void (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef // Character // void (*H_fp)(); +typedef // Subroutine // int (*S_fp)(); + +// E_fp is for real functions when -R is not specified // +typedef void C_f; // complex function // +typedef void H_f; // character function // +typedef void Z_f; // double complex function // +typedef doublereal E_f; // real function with -R not specified // + +// undef any lower-case symbols that your C compiler predefines, e.g.: // + + +// (No such symbols should be defined in a strict ANSI C compiler. + We can avoid trouble with f2c-translated code by using + gcc -ansi [-traditional].) // + + + + + + + + + + + + + + + + + + + + + + + +// Main program // MAIN__() +{ + // System generated locals // + integer i__1; + real r__1, r__2; + doublereal d__1, d__2; + complex q__1; + doublecomplex z__1, z__2, z__3; + logical L__1; + char ch__1[1]; + + // Builtin functions // + void c_div(); + integer pow_ii(); + double pow_ri(), pow_di(); + void pow_ci(); + double pow_dd(); + void pow_zz(); + 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(), + 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(); + integer i_nint(); + double r_sign(); + + // Local variables // + extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(), + fool_(), fooz_(), getem_(); + static char a1[10], a2[10]; + static complex c1, c2; + static doublereal d1, d2; + static integer i1, i2; + static real r1, r2; + + + getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L); +// / // + i__1 = i1 / i2; + fooi_(&i__1); + r__1 = r1 / i1; + foor_(&r__1); + d__1 = d1 / i1; + food_(&d__1); + d__1 = (doublereal) i1; + q__1.r = c1.r / d__1, q__1.i = c1.i / d__1; + fooc_(&q__1); + r__1 = r1 / r2; + foor_(&r__1); + d__1 = r1 / d1; + food_(&d__1); + d__1 = d1 / d2; + food_(&d__1); + d__1 = d1 / r1; + food_(&d__1); + c_div(&q__1, &c1, &c2); + fooc_(&q__1); + q__1.r = c1.r / r1, q__1.i = c1.i / r1; + fooc_(&q__1); + z__1.r = c1.r / d1, z__1.i = c1.i / d1; + fooz_(&z__1); +// ** // + i__1 = pow_ii(&i1, &i2); + fooi_(&i__1); + r__1 = pow_ri(&r1, &i1); + foor_(&r__1); + d__1 = pow_di(&d1, &i1); + food_(&d__1); + pow_ci(&q__1, &c1, &i1); + fooc_(&q__1); + d__1 = (doublereal) r1; + d__2 = (doublereal) r2; + r__1 = pow_dd(&d__1, &d__2); + foor_(&r__1); + d__2 = (doublereal) r1; + d__1 = pow_dd(&d__2, &d1); + food_(&d__1); + d__1 = pow_dd(&d1, &d2); + food_(&d__1); + d__2 = (doublereal) r1; + d__1 = pow_dd(&d1, &d__2); + food_(&d__1); + z__2.r = c1.r, z__2.i = c1.i; + z__3.r = c2.r, z__3.i = c2.i; + pow_zz(&z__1, &z__2, &z__3); + q__1.r = z__1.r, q__1.i = z__1.i; + fooc_(&q__1); + z__2.r = c1.r, z__2.i = c1.i; + z__3.r = r1, z__3.i = 0.; + pow_zz(&z__1, &z__2, &z__3); + q__1.r = z__1.r, q__1.i = z__1.i; + fooc_(&q__1); + z__2.r = c1.r, z__2.i = c1.i; + z__3.r = d1, z__3.i = 0.; + pow_zz(&z__1, &z__2, &z__3); + fooz_(&z__1); +// FFEINTRIN_impABS // + r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ; + foor_(&r__1); +// FFEINTRIN_impACOS // + r__1 = acos(r1); + foor_(&r__1); +// FFEINTRIN_impAIMAG // + r__1 = r_imag(&c1); + foor_(&r__1); +// FFEINTRIN_impAINT // + r__1 = r_int(&r1); + foor_(&r__1); +// FFEINTRIN_impALOG // + r__1 = log(r1); + foor_(&r__1); +// FFEINTRIN_impALOG10 // + r__1 = r_lg10(&r1); + foor_(&r__1); +// FFEINTRIN_impAMAX0 // + r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ; + foor_(&r__1); +// FFEINTRIN_impAMAX1 // + r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ; + foor_(&r__1); +// FFEINTRIN_impAMIN0 // + r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ; + foor_(&r__1); +// FFEINTRIN_impAMIN1 // + r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ; + foor_(&r__1); +// FFEINTRIN_impAMOD // + r__1 = r_mod(&r1, &r2); + foor_(&r__1); +// FFEINTRIN_impANINT // + r__1 = r_nint(&r1); + foor_(&r__1); +// FFEINTRIN_impASIN // + r__1 = asin(r1); + foor_(&r__1); +// FFEINTRIN_impATAN // + r__1 = atan(r1); + foor_(&r__1); +// FFEINTRIN_impATAN2 // + r__1 = atan2(r1, r2); + foor_(&r__1); +// FFEINTRIN_impCABS // + r__1 = c_abs(&c1); + foor_(&r__1); +// FFEINTRIN_impCCOS // + c_cos(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCEXP // + c_exp(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCHAR // + *(unsigned char *)&ch__1[0] = i1; + fooa_(ch__1, 1L); +// FFEINTRIN_impCLOG // + c_log(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCONJG // + r_cnjg(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCOS // + r__1 = cos(r1); + foor_(&r__1); +// FFEINTRIN_impCOSH // + r__1 = cosh(r1); + foor_(&r__1); +// FFEINTRIN_impCSIN // + c_sin(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impCSQRT // + c_sqrt(&q__1, &c1); + fooc_(&q__1); +// FFEINTRIN_impDABS // + d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ; + food_(&d__1); +// FFEINTRIN_impDACOS // + d__1 = acos(d1); + food_(&d__1); +// FFEINTRIN_impDASIN // + d__1 = asin(d1); + food_(&d__1); +// FFEINTRIN_impDATAN // + d__1 = atan(d1); + food_(&d__1); +// FFEINTRIN_impDATAN2 // + d__1 = atan2(d1, d2); + food_(&d__1); +// FFEINTRIN_impDCOS // + d__1 = cos(d1); + food_(&d__1); +// FFEINTRIN_impDCOSH // + d__1 = cosh(d1); + food_(&d__1); +// FFEINTRIN_impDDIM // + d__1 = d_dim(&d1, &d2); + food_(&d__1); +// FFEINTRIN_impDEXP // + d__1 = exp(d1); + food_(&d__1); +// FFEINTRIN_impDIM // + r__1 = r_dim(&r1, &r2); + foor_(&r__1); +// FFEINTRIN_impDINT // + d__1 = d_int(&d1); + food_(&d__1); +// FFEINTRIN_impDLOG // + d__1 = log(d1); + food_(&d__1); +// FFEINTRIN_impDLOG10 // + d__1 = d_lg10(&d1); + food_(&d__1); +// FFEINTRIN_impDMAX1 // + d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ; + food_(&d__1); +// FFEINTRIN_impDMIN1 // + d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ; + food_(&d__1); +// FFEINTRIN_impDMOD // + d__1 = d_mod(&d1, &d2); + food_(&d__1); +// FFEINTRIN_impDNINT // + d__1 = d_nint(&d1); + food_(&d__1); +// FFEINTRIN_impDPROD // + d__1 = (doublereal) r1 * r2; + food_(&d__1); +// FFEINTRIN_impDSIGN // + d__1 = d_sign(&d1, &d2); + food_(&d__1); +// FFEINTRIN_impDSIN // + d__1 = sin(d1); + food_(&d__1); +// FFEINTRIN_impDSINH // + d__1 = sinh(d1); + food_(&d__1); +// FFEINTRIN_impDSQRT // + d__1 = sqrt(d1); + food_(&d__1); +// FFEINTRIN_impDTAN // + d__1 = tan(d1); + food_(&d__1); +// FFEINTRIN_impDTANH // + d__1 = tanh(d1); + food_(&d__1); +// FFEINTRIN_impEXP // + r__1 = exp(r1); + foor_(&r__1); +// FFEINTRIN_impIABS // + i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ; + fooi_(&i__1); +// FFEINTRIN_impICHAR // + i__1 = *(unsigned char *)a1; + fooi_(&i__1); +// FFEINTRIN_impIDIM // + i__1 = i_dim(&i1, &i2); + fooi_(&i__1); +// FFEINTRIN_impIDNINT // + i__1 = i_dnnt(&d1); + fooi_(&i__1); +// FFEINTRIN_impINDEX // + i__1 = i_indx(a1, a2, 10L, 10L); + fooi_(&i__1); +// FFEINTRIN_impISIGN // + i__1 = i_sign(&i1, &i2); + fooi_(&i__1); +// FFEINTRIN_impLEN // + i__1 = i_len(a1, 10L); + fooi_(&i__1); +// FFEINTRIN_impLGE // + L__1 = l_ge(a1, a2, 10L, 10L); + fool_(&L__1); +// FFEINTRIN_impLGT // + L__1 = l_gt(a1, a2, 10L, 10L); + fool_(&L__1); +// FFEINTRIN_impLLE // + L__1 = l_le(a1, a2, 10L, 10L); + fool_(&L__1); +// FFEINTRIN_impLLT // + L__1 = l_lt(a1, a2, 10L, 10L); + fool_(&L__1); +// FFEINTRIN_impMAX0 // + i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ; + fooi_(&i__1); +// FFEINTRIN_impMAX1 // + i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ; + fooi_(&i__1); +// FFEINTRIN_impMIN0 // + i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ; + fooi_(&i__1); +// FFEINTRIN_impMIN1 // + i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ; + fooi_(&i__1); +// FFEINTRIN_impMOD // + i__1 = i1 % i2; + fooi_(&i__1); +// FFEINTRIN_impNINT // + i__1 = i_nint(&r1); + fooi_(&i__1); +// FFEINTRIN_impSIGN // + r__1 = r_sign(&r1, &r2); + foor_(&r__1); +// FFEINTRIN_impSIN // + r__1 = sin(r1); + foor_(&r__1); +// FFEINTRIN_impSINH // + r__1 = sinh(r1); + foor_(&r__1); +// FFEINTRIN_impSQRT // + r__1 = sqrt(r1); + foor_(&r__1); +// FFEINTRIN_impTAN // + r__1 = tan(r1); + foor_(&r__1); +// FFEINTRIN_impTANH // + r__1 = tanh(r1); + foor_(&r__1); +// FFEINTRIN_imp_CMPLX_C // + r__1 = c1.r; + r__2 = c2.r; + q__1.r = r__1, q__1.i = r__2; + fooc_(&q__1); +// FFEINTRIN_imp_CMPLX_D // + z__1.r = d1, z__1.i = d2; + fooz_(&z__1); +// FFEINTRIN_imp_CMPLX_I // + r__1 = (real) i1; + r__2 = (real) i2; + q__1.r = r__1, q__1.i = r__2; + fooc_(&q__1); +// FFEINTRIN_imp_CMPLX_R // + q__1.r = r1, q__1.i = r2; + fooc_(&q__1); +// FFEINTRIN_imp_DBLE_C // + d__1 = (doublereal) c1.r; + food_(&d__1); +// FFEINTRIN_imp_DBLE_D // + d__1 = d1; + food_(&d__1); +// FFEINTRIN_imp_DBLE_I // + d__1 = (doublereal) i1; + food_(&d__1); +// FFEINTRIN_imp_DBLE_R // + d__1 = (doublereal) r1; + food_(&d__1); +// FFEINTRIN_imp_INT_C // + i__1 = (integer) c1.r; + fooi_(&i__1); +// FFEINTRIN_imp_INT_D // + i__1 = (integer) d1; + fooi_(&i__1); +// FFEINTRIN_imp_INT_I // + i__1 = i1; + fooi_(&i__1); +// FFEINTRIN_imp_INT_R // + i__1 = (integer) r1; + fooi_(&i__1); +// FFEINTRIN_imp_REAL_C // + r__1 = c1.r; + foor_(&r__1); +// FFEINTRIN_imp_REAL_D // + r__1 = (real) d1; + foor_(&r__1); +// FFEINTRIN_imp_REAL_I // + r__1 = (real) i1; + foor_(&r__1); +// FFEINTRIN_imp_REAL_R // + r__1 = r1; + foor_(&r__1); + +// FFEINTRIN_imp_INT_D: // + +// FFEINTRIN_specIDINT // + i__1 = (integer) d1; + fooi_(&i__1); + +// FFEINTRIN_imp_INT_R: // + +// FFEINTRIN_specIFIX // + i__1 = (integer) r1; + fooi_(&i__1); +// FFEINTRIN_specINT // + i__1 = (integer) r1; + fooi_(&i__1); + +// FFEINTRIN_imp_REAL_D: // + +// FFEINTRIN_specSNGL // + r__1 = (real) d1; + foor_(&r__1); + +// FFEINTRIN_imp_REAL_I: // + +// FFEINTRIN_specFLOAT // + r__1 = (real) i1; + foor_(&r__1); +// FFEINTRIN_specREAL // + r__1 = (real) i1; + foor_(&r__1); + +} // MAIN__ // + +-------- (end output file from f2c) + +*/ +} + +#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 left, ffebld right) +{ + tree l = ffecom_expr (left); + tree r = ffecom_expr (right); + tree ltype = TREE_TYPE (l); + tree rtype = TREE_TYPE (r); + tree result = NULL_TREE; + + if (l == error_mark_node + || r == error_mark_node) + return error_mark_node; + + if (TREE_CODE (r) == INTEGER_CST) + { + int sgn = tree_int_cst_sgn (r); + + if (sgn == 0) + return convert (ltype, integer_one_node); + + if ((TREE_CODE (ltype) == INTEGER_TYPE) + && (sgn < 0)) + { + /* Reciprocal of integer is either 0, -1, or 1, so after + calculating that (which we leave to the back end to do + or not do optimally), don't bother with any multiplying. */ + + result = ffecom_tree_divide_ (ltype, + convert (ltype, integer_one_node), + l, + NULL_TREE, NULL, NULL); + r = ffecom_1 (NEGATE_EXPR, + rtype, + r); + if ((TREE_INT_CST_LOW (r) & 1) == 0) + result = ffecom_1 (ABS_EXPR, rtype, + result); + } + + /* Generate appropriate series of multiplies, preceded + by divide if the exponent is negative. */ + + l = save_expr (l); + + if (sgn < 0) + { + l = ffecom_tree_divide_ (ltype, + convert (ltype, integer_one_node), + l, + NULL_TREE, NULL, NULL); + r = ffecom_1 (NEGATE_EXPR, rtype, r); + assert (TREE_CODE (r) == INTEGER_CST); + + if (tree_int_cst_sgn (r) < 0) + { /* The "most negative" number. */ + r = ffecom_1 (NEGATE_EXPR, rtype, + ffecom_2 (RSHIFT_EXPR, rtype, + r, + integer_one_node)); + l = save_expr (l); + l = ffecom_2 (MULT_EXPR, ltype, + l, + l); + } + } + + for (;;) + { + if (TREE_INT_CST_LOW (r) & 1) + { + if (result == NULL_TREE) + result = l; + else + result = ffecom_2 (MULT_EXPR, ltype, + result, + l); + } + + r = ffecom_2 (RSHIFT_EXPR, rtype, + r, + integer_one_node); + if (integer_zerop (r)) + break; + assert (TREE_CODE (r) == INTEGER_CST); + + l = save_expr (l); + l = ffecom_2 (MULT_EXPR, ltype, + l, + l); + } + return result; + } + + /* Though rhs isn't a constant, in-line code cannot be expanded + while transforming dummies + because the back end cannot be easily convinced to generate + stores (MODIFY_EXPR), handle temporaries, and so on before + all the appropriate rtx's have been generated for things like + dummy args referenced in rhs -- which doesn't happen until + store_parm_decls() is called (expand_function_start, I believe, + does the actual rtx-stuffing of PARM_DECLs). + + So, in this case, let the caller generate the call to the + run-time-library function to evaluate the power for us. */ + + if (ffecom_transform_only_dummies_) + return NULL_TREE; + + /* Right-hand operand not a constant, expand in-line code to figure + out how to do the multiplies, &c. + + The returned expression is expressed this way in GNU C, where l and + r are the "inputs": + + ({ typeof (r) rtmp = r; + typeof (l) ltmp = l; + typeof (l) result; + + if (rtmp == 0) + result = 1; + else + { + if ((basetypeof (l) == basetypeof (int)) + && (rtmp < 0)) + { + result = ((typeof (l)) 1) / ltmp; + if ((ltmp < 0) && (((-rtmp) & 1) == 0)) + result = -result; + } + else + { + result = 1; + if ((basetypeof (l) != basetypeof (int)) + && (rtmp < 0)) + { + ltmp = ((typeof (l)) 1) / ltmp; + rtmp = -rtmp; + if (rtmp < 0) + { + rtmp = -(rtmp >> 1); + ltmp *= ltmp; + } + } + for (;;) + { + if (rtmp & 1) + result *= ltmp; + if ((rtmp >>= 1) == 0) + break; + ltmp *= ltmp; + } + } + } + result; + }) + + Note that some of the above is compile-time collapsable, such as + the first part of the if statements that checks the base type of + l against int. The if statements are phrased that way to suggest + an easy way to generate the if/else constructs here, knowing that + the back end should (and probably does) eliminate the resulting + dead code (either the int case or the non-int case), something + it couldn't do without the redundant phrasing, requiring explicit + dead-code elimination here, which would be kind of difficult to + read. */ + + { + tree rtmp; + tree ltmp; + tree basetypeof_l_is_int; + tree se; + + basetypeof_l_is_int + = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0); + + se = expand_start_stmt_expr (); + ffecom_push_calltemps (); + + rtmp = ffecom_push_tempvar (rtype, FFETARGET_charactersizeNONE, -1, + TRUE); + ltmp = ffecom_push_tempvar (ltype, FFETARGET_charactersizeNONE, -1, + TRUE); + result = ffecom_push_tempvar (ltype, FFETARGET_charactersizeNONE, -1, + TRUE); + + expand_expr_stmt (ffecom_modify (void_type_node, + rtmp, + r)); + expand_expr_stmt (ffecom_modify (void_type_node, + ltmp, + l)); + expand_start_cond (ffecom_truth_value + (ffecom_2 (EQ_EXPR, integer_type_node, + rtmp, + convert (rtype, integer_zero_node))), + 0); + expand_expr_stmt (ffecom_modify (void_type_node, + result, + convert (ltype, integer_one_node))); + expand_start_else (); + if (!integer_zerop (basetypeof_l_is_int)) + { + expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node, + rtmp, + convert (rtype, + integer_zero_node)), + 0); + expand_expr_stmt (ffecom_modify (void_type_node, + result, + ffecom_tree_divide_ + (ltype, + convert (ltype, integer_one_node), + ltmp, + NULL_TREE, NULL, NULL))); + expand_start_cond (ffecom_truth_value + (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, + ffecom_2 (LT_EXPR, integer_type_node, + ltmp, + convert (ltype, + integer_zero_node)), + ffecom_2 (EQ_EXPR, integer_type_node, + ffecom_2 (BIT_AND_EXPR, + rtype, + ffecom_1 (NEGATE_EXPR, + rtype, + rtmp), + convert (rtype, + integer_one_node)), + convert (rtype, + integer_zero_node)))), + 0); + expand_expr_stmt (ffecom_modify (void_type_node, + result, + ffecom_1 (NEGATE_EXPR, + ltype, + result))); + expand_end_cond (); + expand_start_else (); + } + expand_expr_stmt (ffecom_modify (void_type_node, + result, + convert (ltype, integer_one_node))); + expand_start_cond (ffecom_truth_value + (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node, + ffecom_truth_value_invert + (basetypeof_l_is_int), + ffecom_2 (LT_EXPR, integer_type_node, + rtmp, + convert (rtype, + integer_zero_node)))), + 0); + expand_expr_stmt (ffecom_modify (void_type_node, + ltmp, + ffecom_tree_divide_ + (ltype, + convert (ltype, integer_one_node), + ltmp, + NULL_TREE, NULL, NULL))); + expand_expr_stmt (ffecom_modify (void_type_node, + rtmp, + ffecom_1 (NEGATE_EXPR, rtype, + rtmp))); + expand_start_cond (ffecom_truth_value + (ffecom_2 (LT_EXPR, integer_type_node, + rtmp, + convert (rtype, integer_zero_node))), + 0); + expand_expr_stmt (ffecom_modify (void_type_node, + rtmp, + ffecom_1 (NEGATE_EXPR, rtype, + ffecom_2 (RSHIFT_EXPR, + rtype, + rtmp, + integer_one_node)))); + expand_expr_stmt (ffecom_modify (void_type_node, + ltmp, + ffecom_2 (MULT_EXPR, ltype, + ltmp, + ltmp))); + expand_end_cond (); + expand_end_cond (); + expand_start_loop (1); + expand_start_cond (ffecom_truth_value + (ffecom_2 (BIT_AND_EXPR, rtype, + rtmp, + convert (rtype, integer_one_node))), + 0); + expand_expr_stmt (ffecom_modify (void_type_node, + result, + ffecom_2 (MULT_EXPR, ltype, + result, + ltmp))); + expand_end_cond (); + expand_exit_loop_if_false (NULL, + ffecom_truth_value + (ffecom_modify (rtype, + rtmp, + ffecom_2 (RSHIFT_EXPR, + rtype, + rtmp, + integer_one_node)))); + expand_expr_stmt (ffecom_modify (void_type_node, + ltmp, + ffecom_2 (MULT_EXPR, ltype, + ltmp, + ltmp))); + expand_end_loop (); + expand_end_cond (); + if (!integer_zerop (basetypeof_l_is_int)) + expand_end_cond (); + expand_expr_stmt (result); + + ffecom_pop_calltemps (); + result = expand_end_stmt_expr (se); + TREE_SIDE_EFFECTS (result) = 1; + } + + return result; +} + +#endif +/* ffecom_expr_transform_ -- Transform symbols in expr + + ffebld expr; // FFE expression. + ffecom_expr_transform_ (expr); + + 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: /* :::::::::::::::::::: */ + + if (expr == NULL) + return; + + switch (ffebld_op (expr)) + { + case FFEBLD_opSYMTER: + s = ffebld_symter (expr); + t = ffesymbol_hook (s).decl_tree; + if ((t == NULL_TREE) + && ((ffesymbol_kind (s) != FFEINFO_kindNONE) + || ((ffesymbol_where (s) != FFEINFO_whereNONE) + && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC)))) + { + s = ffecom_sym_transform_ (s); + t = ffesymbol_hook (s).decl_tree; /* Sfunc expr non-dummy, + DIMENSION expr? */ + } + break; /* Ok if (t == NULL) here. */ + + case FFEBLD_opITEM: + ffecom_expr_transform_ (ffebld_head (expr)); + expr = ffebld_trail (expr); + goto tail_recurse; /* :::::::::::::::::::: */ + + default: + break; + } + + switch (ffebld_arity (expr)) + { + case 2: + ffecom_expr_transform_ (ffebld_left (expr)); + expr = ffebld_right (expr); + goto tail_recurse; /* :::::::::::::::::::: */ + + case 1: + expr = ffebld_left (expr); + goto tail_recurse; /* :::::::::::::::::::: */ + + default: + break; + } + + 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, char *name) +{ + switch (tcode) + { + case FFECOM_f2ccodeCHAR: + *type = make_signed_type (CHAR_TYPE_SIZE); + break; + + case FFECOM_f2ccodeSHORT: + *type = make_signed_type (SHORT_TYPE_SIZE); + break; + + case FFECOM_f2ccodeINT: + *type = make_signed_type (INT_TYPE_SIZE); + break; + + case FFECOM_f2ccodeLONG: + *type = make_signed_type (LONG_TYPE_SIZE); + break; + + case FFECOM_f2ccodeLONGLONG: + *type = make_signed_type (LONG_LONG_TYPE_SIZE); + break; + + case FFECOM_f2ccodeCHARPTR: + *type = build_pointer_type (DEFAULT_SIGNED_CHAR + ? signed_char_type_node + : unsigned_char_type_node); + break; + + case FFECOM_f2ccodeFLOAT: + *type = make_node (REAL_TYPE); + TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE; + layout_type (*type); + break; + + case FFECOM_f2ccodeDOUBLE: + *type = make_node (REAL_TYPE); + TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE; + layout_type (*type); + break; + + case FFECOM_f2ccodeLONGDOUBLE: + *type = make_node (REAL_TYPE); + TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE; + layout_type (*type); + break; + + case FFECOM_f2ccodeTWOREALS: + *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node); + break; + + case FFECOM_f2ccodeTWODOUBLEREALS: + *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node); + break; + + default: + assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL); + *type = error_mark_node; + return; + } + + pushdecl (build_decl (TYPE_DECL, + ffecom_get_invented_identifier ("__g77_f2c_%s", + name, 0), + *type)); +} + +#endif +#if FFECOM_targetCURRENT == FFECOM_targetGCC +/* Set the f2c list-directed-I/O code for whatever (integral) type has the + given size. */ + +static void +ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size, + int code) +{ + int j; + tree t; + + for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) + if (((t = ffecom_tree_type[bt][j]) != NULL_TREE) + && (TREE_INT_CST_LOW (TYPE_SIZE (t)) == size)) + { + assert (code != -1); + ffecom_f2c_typecode_[bt][j] = code; + code = -1; + } +} + +#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) +{ + tree cbtype; + tree cbt; + tree size; + + if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON) + return global; + + if (ffeglobal_common_init (global)) + return global; + + cbt = ffeglobal_hook (global); + if ((cbt == NULL_TREE) + || !ffeglobal_common_have_size (global)) + return global; /* No need to make common, never ref'd. */ + + suspend_momentary (); + + DECL_EXTERNAL (cbt) = 0; + + /* Give the array a size now. */ + + size = build_int_2 (ffeglobal_common_size (global), 0); + + cbtype = TREE_TYPE (cbt); + TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node, + integer_one_node, + size); + if (!TREE_TYPE (size)) + TREE_TYPE (size) = TYPE_DOMAIN (cbtype); + layout_type (cbtype); + + cbt = start_decl (cbt, FALSE); + assert (cbt == ffeglobal_hook (global)); + + finish_decl (cbt, NULL_TREE, FALSE); + + return global; +} + +#endif +/* Finish up any untransformed symbols. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static ffesymbol +ffecom_finish_symbol_transform_ (ffesymbol s) +{ + if (s == NULL) + return s; + + /* It's easy to know to transform an untransformed symbol, to make sure + we put out debugging info for it. But COMMON variables, unlike + EQUIVALENCE ones, aren't given declarations in addition to the + tree expressions that specify offsets, because COMMON variables + can be referenced in the outer scope where only dummy arguments + (PARM_DECLs) should really be seen. To be safe, just don't do any + VAR_DECLs for COMMON variables when we transform them for real + use, and therefore we do all the VAR_DECL creating here. */ + + if ((ffesymbol_hook (s).decl_tree == NULL_TREE) + && ((ffesymbol_kind (s) != FFEINFO_kindNONE) + || ((ffesymbol_where (s) != FFEINFO_whereNONE) + && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))) + && (ffesymbol_where (s) != FFEINFO_whereDUMMY)) + /* Not transformed, and not CHARACTER*(*), and not a dummy + argument, which can happen only if the entry point names + it "rides in on" are all invalidated for other reasons. */ + s = ffecom_sym_transform_ (s); + + if ((ffesymbol_where (s) == FFEINFO_whereCOMMON) + && (ffesymbol_hook (s).decl_tree != error_mark_node)) + { +#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING + int yes = suspend_momentary (); + + /* This isn't working, at least for dbxout. The .s file looks + okay to me (burley), but in gdb 4.9 at least, the variables + appear to reside somewhere outside of the common area, so + it doesn't make sense to mislead anyone by generating the info + on those variables until this is fixed. NOTE: Same problem + with EQUIVALENCE, sadly...see similar #if later. */ + ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)), + ffesymbol_storage (s)); + + resume_momentary (yes); +#endif + } + + 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, char *name) +{ + int i; + char *newname; + tree id; + + newname = xmalloc ((i = strlen (name)) + 1 + + ffe_is_underscoring () + + us); + memcpy (newname, name, i); + newname[i] = '_'; + newname[i + us] = '_'; + newname[i + 1 + us] = '\0'; + id = get_identifier (newname); + + free (newname); + + 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) +{ + char us; + char *name = ffesymbol_text (s); + + /* If name is a built-in name, just return it as is. */ + + if (!ffe_is_underscoring () + || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0) +#if FFETARGET_isENFORCED_MAIN_NAME + || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0) +#else + || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0) +#endif + || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0)) + return get_identifier (name); + + us = ffe_is_second_underscore () + ? (strchr (name, '_') != NULL) + : 0; + + return ffecom_get_appended_identifier_ (us, name); +} + +#endif +/* Decide whether to append underscore to internal name before calling + get_identifier. + + This is for non-external, top-function-context names only. Transform + identifier so it doesn't conflict with the transformed result + of using a _different_ external name. E.g. if "CALL FOO" is + transformed into "FOO_();", then the variable in "FOO_ = 3" + must be transformed into something that does not conflict, since + these two things should be independent. + + The transformation is as follows. If the name does not contain + an underscore, there is no possible conflict, so just return. + 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_ (char *name) +{ + /* If name does not contain an underscore, just return it as is. */ + + if (!ffe_is_underscoring () + || (strchr (name, '_') == NULL)) + return get_identifier (name); + + return ffecom_get_appended_identifier_ (ffe_is_second_underscore (), + name); +} + +#endif +/* ffecom_gen_sfuncdef_ -- Generate definition of statement function + + tree t; + ffesymbol s; // kindFUNCTION, whereIMMEDIATE. + t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s), + ffesymbol_kindtype(s)); + + 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) +{ + ffebld expr = ffesymbol_sfexpr (s); + tree type; + tree func; + tree result; + bool charfunc = (bt == FFEINFO_basictypeCHARACTER); + static bool recurse = FALSE; + int yes; + int old_lineno = lineno; + char *old_input_filename = input_filename; + + ffecom_nested_entry_ = s; + + /* For now, we don't have a handy pointer to where the sfunc is actually + defined, though that should be easy to add to an ffesymbol. (The + token/where info available might well point to the place where the type + of the sfunc is declared, especially if that precedes the place where + the sfunc itself is defined, which is typically the case.) We should + put out a null pointer rather than point somewhere wrong, but I want to + see how it works at this point. */ + + input_filename = ffesymbol_where_filename (s); + lineno = ffesymbol_where_filelinenum (s); + + /* Pretransform the expression so any newly discovered things belong to the + outer program unit, not to the statement function. */ + + ffecom_expr_transform_ (expr); + + /* Make sure no recursive invocation of this fn (a specific case of failing + to pretransform an sfunc's expression, i.e. where its expression + references another untransformed sfunc) happens. */ + + assert (!recurse); + recurse = TRUE; + + yes = suspend_momentary (); + + push_f_function_context (); + + ffecom_push_calltemps (); + + if (charfunc) + type = void_type_node; + else + { + type = ffecom_tree_type[bt][kt]; + if (type == NULL_TREE) + type = integer_type_node; /* _sym_exec_transition reports + error. */ + } + + start_function (ffecom_get_identifier_ (ffesymbol_text (s)), + build_function_type (type, NULL_TREE), + 1, /* nested/inline */ + 0); /* TREE_PUBLIC */ + + /* We don't worry about COMPLEX return values here, because this is + entirely internal to our code, and gcc has the ability to return COMPLEX + directly as a value. */ + + yes = suspend_momentary (); + + if (charfunc) + { /* Prepend arg for where result goes. */ + tree type; + + type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt]; + + result = ffecom_get_invented_identifier ("__g77_%s", + "result", 0); + + ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */ + + type = build_pointer_type (type); + result = build_decl (PARM_DECL, result, type); + + push_parm_decl (result); + } + else + result = NULL_TREE; /* Not ref'd if !charfunc. */ + + ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE); + + resume_momentary (yes); + + store_parm_decls (0); + + ffecom_start_compstmt_ (); + + if (expr != NULL) + { + if (charfunc) + { + ffetargetCharacterSize sz = ffesymbol_size (s); + tree result_length; + + result_length = build_int_2 (sz, 0); + TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node; + + ffecom_let_char_ (result, result_length, sz, expr); + expand_null_return (); + } + else + expand_return (ffecom_modify (NULL_TREE, + DECL_RESULT (current_function_decl), + ffecom_expr (expr))); + + clear_momentary (); + } + + ffecom_end_compstmt_ (); + + func = current_function_decl; + finish_function (1); + + ffecom_pop_calltemps (); + + pop_f_function_context (); + + resume_momentary (yes); + + recurse = FALSE; + + lineno = old_lineno; + input_filename = old_input_filename; + + ffecom_nested_entry_ = NULL; + + return func; +} + +#endif + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static char * +ffecom_gfrt_args_ (ffecomGfrt ix) +{ + return ffecom_gfrt_argstring_[ix]; +} + +#endif +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_gfrt_tree_ (ffecomGfrt ix) +{ + if (ffecom_gfrt_[ix] == NULL_TREE) + ffecom_make_gfrt_ (ix); + + return ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])), + ffecom_gfrt_[ix]); +} + +#endif +/* Return initialize-to-zero expression for this VAR_DECL. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_init_zero_ (tree decl) +{ + tree init; + int incremental = TREE_STATIC (decl); + tree type = TREE_TYPE (decl); + + if (incremental) + { + int momentary = suspend_momentary (); + push_obstacks_nochange (); + if (TREE_PERMANENT (decl)) + end_temporary_allocation (); + make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0); + assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1); + pop_obstacks (); + resume_momentary (momentary); + } + + push_momentary (); + + if ((TREE_CODE (type) != ARRAY_TYPE) + && (TREE_CODE (type) != RECORD_TYPE) + && (TREE_CODE (type) != UNION_TYPE) + && !incremental) + init = convert (type, integer_zero_node); + else if (!incremental) + { + int momentary = suspend_momentary (); + + init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE); + TREE_CONSTANT (init) = 1; + TREE_STATIC (init) = 1; + + resume_momentary (momentary); + } + else + { + int momentary = suspend_momentary (); + + assemble_zeros (int_size_in_bytes (type)); + init = error_mark_node; + + resume_momentary (momentary); + } + + pop_momentary_nofree (); + + return init; +} + +#endif +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg, + tree *maybe_tree) +{ + tree expr_tree; + tree length_tree; + + switch (ffebld_op (arg)) + { + case FFEBLD_opCONTER: /* For F90, check 0-length. */ + if (ffetarget_length_character1 + (ffebld_constant_character1 + (ffebld_conter (arg))) == 0) + { + *maybe_tree = integer_zero_node; + return convert (tree_type, integer_zero_node); + } + + *maybe_tree = integer_one_node; + expr_tree = build_int_2 (*ffetarget_text_character1 + (ffebld_constant_character1 + (ffebld_conter (arg))), + 0); + TREE_TYPE (expr_tree) = tree_type; + return expr_tree; + + case FFEBLD_opSYMTER: + case FFEBLD_opARRAYREF: + case FFEBLD_opFUNCREF: + case FFEBLD_opSUBSTR: + ffecom_push_calltemps (); + ffecom_char_args_ (&expr_tree, &length_tree, arg); + ffecom_pop_calltemps (); + + if ((expr_tree == error_mark_node) + || (length_tree == error_mark_node)) + { + *maybe_tree = error_mark_node; + return error_mark_node; + } + + if (integer_zerop (length_tree)) + { + *maybe_tree = integer_zero_node; + return convert (tree_type, integer_zero_node); + } + + expr_tree + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))), + expr_tree); + expr_tree + = ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))), + expr_tree, + integer_one_node); + expr_tree = convert (tree_type, expr_tree); + + if (TREE_CODE (length_tree) == INTEGER_CST) + *maybe_tree = integer_one_node; + else /* Must check length at run time. */ + *maybe_tree + = ffecom_truth_value + (ffecom_2 (GT_EXPR, integer_type_node, + length_tree, + ffecom_f2c_ftnlen_zero_node)); + return expr_tree; + + case FFEBLD_opPAREN: + case FFEBLD_opCONVERT: + if (ffeinfo_size (ffebld_info (arg)) == 0) + { + *maybe_tree = integer_zero_node; + return convert (tree_type, integer_zero_node); + } + return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg), + maybe_tree); + + case FFEBLD_opCONCATENATE: + { + tree maybe_left; + tree maybe_right; + tree expr_left; + tree expr_right; + + expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg), + &maybe_left); + expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg), + &maybe_right); + *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node, + maybe_left, + maybe_right); + expr_tree = ffecom_3 (COND_EXPR, tree_type, + maybe_left, + expr_left, + expr_right); + return expr_tree; + } + + default: + assert ("bad op in ICHAR" == NULL); + return error_mark_node; + } +} + +#endif +/* ffecom_intrinsic_len_ -- Return length info for char arg (LEN()) + + tree length_arg; + ffebld expr; + length_arg = ffecom_intrinsic_len_ (expr); + + Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF + 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) +{ + ffetargetCharacter1 val; + tree length; + + switch (ffebld_op (expr)) + { + case FFEBLD_opCONTER: + val = ffebld_constant_character1 (ffebld_conter (expr)); + length = build_int_2 (ffetarget_length_character1 (val), 0); + TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node; + break; + + case FFEBLD_opSYMTER: + { + ffesymbol s = ffebld_symter (expr); + tree item; + + item = ffesymbol_hook (s).decl_tree; + if (item == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + item = ffesymbol_hook (s).decl_tree; + } + if (ffesymbol_kind (s) == FFEINFO_kindENTITY) + { + if (ffesymbol_size (s) == FFETARGET_charactersizeNONE) + length = ffesymbol_hook (s).length_tree; + else + { + length = build_int_2 (ffesymbol_size (s), 0); + TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node; + } + } + else if (item == error_mark_node) + length = error_mark_node; + else /* FFEINFO_kindFUNCTION: */ + length = NULL_TREE; + } + break; + + case FFEBLD_opARRAYREF: + length = ffecom_intrinsic_len_ (ffebld_left (expr)); + break; + + case FFEBLD_opSUBSTR: + { + ffebld start; + ffebld end; + ffebld thing = ffebld_right (expr); + tree start_tree; + tree end_tree; + + assert (ffebld_op (thing) == FFEBLD_opITEM); + start = ffebld_head (thing); + thing = ffebld_trail (thing); + assert (ffebld_trail (thing) == NULL); + end = ffebld_head (thing); + + length = ffecom_intrinsic_len_ (ffebld_left (expr)); + + if (length == error_mark_node) + break; + + if (start == NULL) + { + if (end == NULL) + ; + else + { + length = convert (ffecom_f2c_ftnlen_type_node, + ffecom_expr (end)); + } + } + else + { + start_tree = convert (ffecom_f2c_ftnlen_type_node, + ffecom_expr (start)); + + if (start_tree == error_mark_node) + { + length = error_mark_node; + break; + } + + if (end == NULL) + { + length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + ffecom_2 (MINUS_EXPR, + ffecom_f2c_ftnlen_type_node, + length, + start_tree)); + } + else + { + end_tree = convert (ffecom_f2c_ftnlen_type_node, + ffecom_expr (end)); + + if (end_tree == error_mark_node) + { + length = error_mark_node; + break; + } + + length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + ffecom_2 (MINUS_EXPR, + ffecom_f2c_ftnlen_type_node, + end_tree, start_tree)); + } + } + } + break; + + case FFEBLD_opCONCATENATE: + length + = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + ffecom_intrinsic_len_ (ffebld_left (expr)), + ffecom_intrinsic_len_ (ffebld_right (expr))); + break; + + case FFEBLD_opFUNCREF: + case FFEBLD_opCONVERT: + length = build_int_2 (ffebld_size (expr), 0); + TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node; + break; + + default: + assert ("bad op for single char arg expr" == NULL); + length = ffecom_f2c_ftnlen_zero_node; + break; + } + + assert (length != NULL_TREE); + + return length; +} + +#endif +/* ffecom_let_char_ -- Do assignment stuff for character type + + tree dest_tree; // destination (ADDR_EXPR) + tree dest_length; // length (INT_CST/INDIRECT_REF(PARM_DECL)) + ffetargetCharacterSize dest_size; // length + ffebld source; // source expression + ffecom_let_char_(dest_tree,dest_length,dest_size,source); + + 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) +{ + ffecomConcatList_ catlist; + tree source_length; + tree source_tree; + tree expr_tree; + + if ((dest_tree == error_mark_node) + || (dest_length == error_mark_node)) + return; + + assert (dest_tree != NULL_TREE); + assert (dest_length != NULL_TREE); + + /* Source might be an opCONVERT, which just means it is a different size + than the destination. Since the underlying implementation here handles + that (directly or via the s_copy or s_cat run-time-library functions), + we don't need the "convenience" of an opCONVERT that tells us to + truncate or blank-pad, particularly since the resulting implementation + would probably be slower than otherwise. */ + + while (ffebld_op (source) == FFEBLD_opCONVERT) + source = ffebld_left (source); + + catlist = ffecom_concat_list_new_ (source, dest_size); + switch (ffecom_concat_list_count_ (catlist)) + { + case 0: /* Shouldn't happen, but in case it does... */ + ffecom_concat_list_kill_ (catlist); + source_tree = null_pointer_node; + source_length = ffecom_f2c_ftnlen_zero_node; + expr_tree = build_tree_list (NULL_TREE, dest_tree); + TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree); + TREE_CHAIN (TREE_CHAIN (expr_tree)) + = build_tree_list (NULL_TREE, dest_length); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))) + = build_tree_list (NULL_TREE, source_length); + + expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree); + TREE_SIDE_EFFECTS (expr_tree) = 1; + + expand_expr_stmt (expr_tree); + + return; + + case 1: /* The (fairly) easy case. */ + ffecom_char_args_ (&source_tree, &source_length, + ffecom_concat_list_expr_ (catlist, 0)); + ffecom_concat_list_kill_ (catlist); + assert (source_tree != NULL_TREE); + assert (source_length != NULL_TREE); + + if ((source_tree == error_mark_node) + || (source_length == error_mark_node)) + return; + + if (dest_size == 1) + { + dest_tree + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE + (dest_tree))), + dest_tree); + dest_tree + = ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE + (dest_tree))), + dest_tree, + integer_one_node); + source_tree + = ffecom_1 (INDIRECT_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE + (source_tree))), + source_tree); + source_tree + = ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE + (source_tree))), + source_tree, + integer_one_node); + + expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree); + + expand_expr_stmt (expr_tree); + + return; + } + + expr_tree = build_tree_list (NULL_TREE, dest_tree); + TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree); + TREE_CHAIN (TREE_CHAIN (expr_tree)) + = build_tree_list (NULL_TREE, dest_length); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))) + = build_tree_list (NULL_TREE, source_length); + + expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree); + TREE_SIDE_EFFECTS (expr_tree) = 1; + + expand_expr_stmt (expr_tree); + + return; + + default: /* Must actually concatenate things. */ + break; + } + + /* Heavy-duty concatenation. */ + + { + int count = ffecom_concat_list_count_ (catlist); + int i; + tree lengths; + tree items; + tree length_array; + tree item_array; + tree citem; + tree clength; + + length_array + = lengths + = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node, + FFETARGET_charactersizeNONE, count, TRUE); + item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node, + FFETARGET_charactersizeNONE, + count, TRUE); + + for (i = 0; i < count; ++i) + { + ffecom_char_args_ (&citem, &clength, + ffecom_concat_list_expr_ (catlist, i)); + if ((citem == error_mark_node) + || (clength == error_mark_node)) + { + ffecom_concat_list_kill_ (catlist); + return; + } + + items + = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items), + ffecom_modify (void_type_node, + ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))), + item_array, + build_int_2 (i, 0)), + citem), + items); + lengths + = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths), + ffecom_modify (void_type_node, + ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))), + length_array, + build_int_2 (i, 0)), + clength), + lengths); + } + + expr_tree = build_tree_list (NULL_TREE, dest_tree); + TREE_CHAIN (expr_tree) + = build_tree_list (NULL_TREE, + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (items)), + items)); + TREE_CHAIN (TREE_CHAIN (expr_tree)) + = build_tree_list (NULL_TREE, + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (lengths)), + lengths)); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))) + = build_tree_list + (NULL_TREE, + ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node, + convert (ffecom_f2c_ftnlen_type_node, + build_int_2 (count, 0)))); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))) + = build_tree_list (NULL_TREE, dest_length); + + expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree); + TREE_SIDE_EFFECTS (expr_tree) = 1; + + expand_expr_stmt (expr_tree); + } + + ffecom_concat_list_kill_ (catlist); +} + +#endif +/* ffecom_make_gfrt_ -- Make initial info for run-time routine + + ffecomGfrt ix; + ffecom_make_gfrt_(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) +{ + tree t; + tree ttype; + + push_obstacks_nochange (); + end_temporary_allocation (); + + switch (ffecom_gfrt_type_[ix]) + { + case FFECOM_rttypeVOID_: + ttype = void_type_node; + break; + + case FFECOM_rttypeINT_: + ttype = integer_type_node; + break; + + case FFECOM_rttypeINTEGER_: + ttype = ffecom_f2c_integer_type_node; + break; + + case FFECOM_rttypeLONGINT_: + ttype = ffecom_f2c_longint_type_node; + break; + + case FFECOM_rttypeLOGICAL_: + ttype = ffecom_f2c_logical_type_node; + break; + + case FFECOM_rttypeREAL_F2C_: + ttype = ffecom_f2c_real_type_node; + break; + + case FFECOM_rttypeREAL_GNU_: + ttype = ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]; + break; + + case FFECOM_rttypeCOMPLEX_F2C_: + ttype = void_type_node; + break; + + case FFECOM_rttypeCOMPLEX_GNU_: + ttype = ffecom_f2c_complex_type_node; + break; + + case FFECOM_rttypeDOUBLE_: + ttype = double_type_node; + break; + + case FFECOM_rttypeDBLCMPLX_F2C_: + ttype = void_type_node; + break; + + case FFECOM_rttypeDBLCMPLX_GNU_: + ttype = ffecom_f2c_doublecomplex_type_node; + break; + + case FFECOM_rttypeCHARACTER_: + ttype = void_type_node; + break; + + default: + ttype = NULL; + assert ("bad rttype" == NULL); + break; + } + + ttype = build_function_type (ttype, NULL_TREE); + t = build_decl (FUNCTION_DECL, + get_identifier (ffecom_gfrt_name_[ix]), + ttype); + DECL_EXTERNAL (t) = 1; + TREE_PUBLIC (t) = 1; + TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0; + + t = start_decl (t, TRUE); + + finish_decl (t, NULL_TREE, TRUE); + + resume_temporary_allocation (); + pop_obstacks (); + + 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) +{ + ffesymbol s = ffestorag_symbol (st); + + if (ffesymbol_namelisted (s)) + 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 +#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING +static void +ffecom_member_phase2_ (ffestorag mst, ffestorag st) +{ + ffesymbol s; + tree t; + tree mt; + tree type; + + if ((mst == NULL) + || ((mt = ffestorag_hook (mst)) == NULL) + || (mt == error_mark_node)) + return; + + if ((st == NULL) + || ((s = ffestorag_symbol (st)) == NULL)) + return; + + type = ffecom_type_localvar_ (s, + ffesymbol_basictype (s), + ffesymbol_kindtype (s)); + if (type == error_mark_node) + return; + + t = build_decl (VAR_DECL, + ffecom_get_identifier_ (ffesymbol_text (s)), + type); + + TREE_STATIC (t) = TREE_STATIC (mt); + DECL_INITIAL (t) = NULL_TREE; + TREE_ASM_WRITTEN (t) = 1; + + DECL_RTL (t) + = gen_rtx (MEM, TYPE_MODE (type), + plus_constant (XEXP (DECL_RTL (mt), 0), + ffestorag_modulo (mst) + + ffestorag_offset (st) + - ffestorag_offset (mst))); + + t = start_decl (t, FALSE); + + finish_decl (t, NULL_TREE, FALSE); +} + +#endif +#endif +/* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order + + Ignores STAR (alternate-return) dummies. All other get exec-transitioned + (which generates their trees) and then their trees get push_parm_decl'd. + + The second arg is TRUE if the dummies are for a statement function, in + which case lengths are not pushed for character arguments (since they are + 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) +{ + ffebld dummy; + ffebld dumlist; + ffesymbol s; + tree parm; + + ffecom_transform_only_dummies_ = TRUE; + + /* First push the parms corresponding to actual dummy "contents". */ + + for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist)) + { + dummy = ffebld_head (dumlist); + switch (ffebld_op (dummy)) + { + case FFEBLD_opSTAR: + case FFEBLD_opANY: + continue; /* Forget alternate returns. */ + + default: + break; + } + assert (ffebld_op (dummy) == FFEBLD_opSYMTER); + s = ffebld_symter (dummy); + parm = ffesymbol_hook (s).decl_tree; + if (parm == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + parm = ffesymbol_hook (s).decl_tree; + assert (parm != NULL_TREE); + } + if (parm != error_mark_node) + push_parm_decl (parm); + } + + /* Then, for CHARACTER dummies, push the parms giving their lengths. */ + + for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist)) + { + dummy = ffebld_head (dumlist); + switch (ffebld_op (dummy)) + { + case FFEBLD_opSTAR: + case FFEBLD_opANY: + continue; /* Forget alternate returns, they mean + NOTHING! */ + + default: + break; + } + s = ffebld_symter (dummy); + if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER) + continue; /* Only looking for CHARACTER arguments. */ + if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE)) + continue; /* Stmtfunc arg with known size needs no + length param. */ + if (ffesymbol_kind (s) != FFEINFO_kindENTITY) + continue; /* Only looking for variables and arrays. */ + parm = ffesymbol_hook (s).length_tree; + assert (parm != NULL_TREE); + if (parm != error_mark_node) + push_parm_decl (parm); + } + + 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 fn = ffecom_primary_entry_; + ffebld arglist; + tree id; /* Identifier (name) of function. */ + tree type; /* Type of function. */ + tree result; /* Result of function. */ + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffeglobal g; + ffeglobalType gt; + ffeglobalType egt = FFEGLOBAL_type; + bool charfunc; + bool cmplxfunc; + bool altentries = (ffecom_num_entrypoints_ != 0); + bool multi + = altentries + && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION) + && (ffecom_master_bt_ == FFEINFO_basictypeNONE); + bool main_program = FALSE; + int old_lineno = lineno; + char *old_input_filename = input_filename; + int yes; + + assert (fn != NULL); + assert (ffesymbol_hook (fn).decl_tree == NULL_TREE); + + input_filename = ffesymbol_where_filename (fn); + lineno = ffesymbol_where_filelinenum (fn); + + /* c-parse.y indeed does call suspend_momentary and not only ignores the + return value, but also never calls resume_momentary, when starting an + outer function (see "fndef:", "setspecs:", and so on). So g77 does the + same thing. It shouldn't be a problem since start_function calls + temporary_allocation, but it might be necessary. If it causes a problem + here, then maybe there's a bug lurking in gcc. NOTE: This identical + comment appears twice in thist file. */ + + suspend_momentary (); + + switch (ffecom_primary_entry_kind_) + { + case FFEINFO_kindPROGRAM: + main_program = TRUE; + gt = FFEGLOBAL_typeMAIN; + bt = FFEINFO_basictypeNONE; + kt = FFEINFO_kindtypeNONE; + type = ffecom_tree_fun_type_void; + charfunc = FALSE; + cmplxfunc = FALSE; + break; + + case FFEINFO_kindBLOCKDATA: + gt = FFEGLOBAL_typeBDATA; + bt = FFEINFO_basictypeNONE; + kt = FFEINFO_kindtypeNONE; + type = ffecom_tree_fun_type_void; + charfunc = FALSE; + cmplxfunc = FALSE; + break; + + case FFEINFO_kindFUNCTION: + gt = FFEGLOBAL_typeFUNC; + egt = FFEGLOBAL_typeEXT; + bt = ffesymbol_basictype (fn); + kt = ffesymbol_kindtype (fn); + if (bt == FFEINFO_basictypeNONE) + { + ffeimplic_establish_symbol (fn); + if (ffesymbol_funcresult (fn) != NULL) + ffeimplic_establish_symbol (ffesymbol_funcresult (fn)); + bt = ffesymbol_basictype (fn); + kt = ffesymbol_kindtype (fn); + } + + if (multi) + charfunc = cmplxfunc = FALSE; + else if (bt == FFEINFO_basictypeCHARACTER) + charfunc = TRUE, cmplxfunc = FALSE; + else if ((bt == FFEINFO_basictypeCOMPLEX) + && ffesymbol_is_f2c (fn) + && !altentries) + charfunc = FALSE, cmplxfunc = TRUE; + else + charfunc = cmplxfunc = FALSE; + + if (multi || charfunc) + type = ffecom_tree_fun_type_void; + else if (ffesymbol_is_f2c (fn) && !altentries) + type = ffecom_tree_fun_type[bt][kt]; + else + type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE); + + if ((type == NULL_TREE) + || (TREE_TYPE (type) == NULL_TREE)) + type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */ + break; + + case FFEINFO_kindSUBROUTINE: + gt = FFEGLOBAL_typeSUBR; + egt = FFEGLOBAL_typeEXT; + bt = FFEINFO_basictypeNONE; + kt = FFEINFO_kindtypeNONE; + if (ffecom_is_altreturning_) + type = ffecom_tree_subr_type; + else + type = ffecom_tree_fun_type_void; + charfunc = FALSE; + cmplxfunc = FALSE; + break; + + default: + assert ("say what??" == NULL); + /* Fall through. */ + case FFEINFO_kindANY: + gt = FFEGLOBAL_typeANY; + bt = FFEINFO_basictypeNONE; + kt = FFEINFO_kindtypeNONE; + type = error_mark_node; + charfunc = FALSE; + cmplxfunc = FALSE; + break; + } + + if (altentries) + id = ffecom_get_invented_identifier ("__g77_masterfun_%s", + ffesymbol_text (fn), + 0); +#if FFETARGET_isENFORCED_MAIN + else if (main_program) + id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME); +#endif + else + id = ffecom_get_external_identifier_ (fn); + + start_function (id, + type, + 0, /* nested/inline */ + !altentries); /* TREE_PUBLIC */ + + if (!altentries + && ((g = ffesymbol_global (fn)) != NULL) + && ((ffeglobal_type (g) == gt) + || (ffeglobal_type (g) == egt))) + { + ffeglobal_set_hook (g, current_function_decl); + } + + yes = suspend_momentary (); + + /* Arg handling needs exec-transitioned ffesymbols to work with. But + exec-transitioning needs current_function_decl to be filled in. So we + do these things in two phases. */ + + if (altentries) + { /* 1st arg identifies which entrypoint. */ + ffecom_which_entrypoint_decl_ + = build_decl (PARM_DECL, + ffecom_get_invented_identifier ("__g77_%s", + "which_entrypoint", + 0), + integer_type_node); + push_parm_decl (ffecom_which_entrypoint_decl_); + } + + if (charfunc + || cmplxfunc + || multi) + { /* Arg for result (return value). */ + tree type; + tree length; + + if (charfunc) + type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt]; + else if (cmplxfunc) + type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt]; + else + type = ffecom_multi_type_node_; + + result = ffecom_get_invented_identifier ("__g77_%s", + "result", 0); + + /* Make length arg _and_ enhance type info for CHAR arg itself. */ + + if (charfunc) + length = ffecom_char_enhance_arg_ (&type, fn); + else + length = NULL_TREE; /* Not ref'd if !charfunc. */ + + type = build_pointer_type (type); + result = build_decl (PARM_DECL, result, type); + + push_parm_decl (result); + if (multi) + ffecom_multi_retval_ = result; + else + ffecom_func_result_ = result; + + if (charfunc) + { + push_parm_decl (length); + ffecom_func_length_ = length; + } + } + + if (ffecom_primary_entry_is_proc_) + { + if (altentries) + arglist = ffecom_master_arglist_; + else + arglist = ffesymbol_dummyargs (fn); + ffecom_push_dummy_decls_ (arglist, FALSE); + } + + resume_momentary (yes); + + store_parm_decls (main_program ? 1 : 0); + + ffecom_start_compstmt_ (); + + lineno = old_lineno; + input_filename = old_input_filename; + + /* This handles any symbols still untransformed, in case -g specified. + This used to be done in ffecom_finish_progunit, but it turns out to + be necessary to do it here so that statement functions are + expanded before code. But don't bother for BLOCK DATA. */ + + if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA) + ffesymbol_drive (ffecom_finish_symbol_transform_); +} + +#endif +/* ffecom_sym_transform_ -- Transform FFE sym into backend sym + + ffesymbol s; + ffecom_sym_transform_(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) +{ + tree t; /* Transformed thingy. */ + tree tlen; /* Length if CHAR*(*). */ + bool addr; /* Is t the address of the thingy? */ + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffeglobal g; + int yes; + int old_lineno = lineno; + char *old_input_filename = input_filename; + + if (ffesymbol_sfdummyparent (s) == NULL) + { + input_filename = ffesymbol_where_filename (s); + lineno = ffesymbol_where_filelinenum (s); + } + else + { + ffesymbol sf = ffesymbol_sfdummyparent (s); + + input_filename = ffesymbol_where_filename (sf); + lineno = ffesymbol_where_filelinenum (sf); + } + + bt = ffeinfo_basictype (ffebld_info (s)); + kt = ffeinfo_kindtype (ffebld_info (s)); + + t = NULL_TREE; + tlen = NULL_TREE; + addr = FALSE; + + switch (ffesymbol_kind (s)) + { + case FFEINFO_kindNONE: + switch (ffesymbol_where (s)) + { + case FFEINFO_whereDUMMY: /* Subroutine or function. */ + assert (ffecom_transform_only_dummies_); + + /* Before 0.4, this could be ENTITY/DUMMY, but see + ffestu_sym_end_transition -- no longer true (in particular, if + it could be an ENTITY, it _will_ be made one, so that + possibility won't come through here). So we never make length + arg for CHARACTER type. */ + + 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; + + case FFEINFO_whereGLOBAL: /* Subroutine or function. */ + assert (!ffecom_transform_only_dummies_); + + if (((g = ffesymbol_global (s)) != NULL) + && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) + || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)) + && (ffeglobal_hook (g) != NULL_TREE) + && ffe_is_globals ()) + { + t = ffeglobal_hook (g); + break; + } + + push_obstacks_nochange (); + end_temporary_allocation (); + + t = build_decl (FUNCTION_DECL, + ffecom_get_external_identifier_ (s), + ffecom_tree_subr_type); /* Assume subr. */ + DECL_EXTERNAL (t) = 1; + TREE_PUBLIC (t) = 1; + + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); + + if ((g != NULL) + && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) + || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) + ffeglobal_set_hook (g, t); + + resume_temporary_allocation (); + pop_obstacks (); + + break; + + default: + assert ("NONE where unexpected" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + break; + } + break; + + case FFEINFO_kindENTITY: + switch (ffeinfo_where (ffesymbol_info (s))) + { + + case FFEINFO_whereCONSTANT: /* ~~debugging info needed? */ + assert (!ffecom_transform_only_dummies_); + t = error_mark_node; /* Shouldn't ever see this in expr. */ + break; + + case FFEINFO_whereLOCAL: + assert (!ffecom_transform_only_dummies_); + + { + ffestorag st = ffesymbol_storage (s); + tree type; + + if ((st != NULL) + && (ffestorag_size (st) == 0)) + { + t = error_mark_node; + break; + } + + yes = suspend_momentary (); + type = ffecom_type_localvar_ (s, bt, kt); + resume_momentary (yes); + + if (type == error_mark_node) + { + t = error_mark_node; + break; + } + + if ((st != NULL) + && (ffestorag_parent (st) != NULL)) + { /* Child of EQUIVALENCE parent. */ + ffestorag est; + tree et; + int yes; + ffetargetOffset offset; + + est = ffestorag_parent (st); + ffecom_transform_equiv_ (est); + + et = ffestorag_hook (est); + assert (et != NULL_TREE); + + if (! TREE_STATIC (et)) + put_var_into_stack (et); + + yes = suspend_momentary (); + + offset = ffestorag_modulo (est) + + ffestorag_offset (ffesymbol_storage (s)) + - ffestorag_offset (est); + + ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset); + + /* (t_type *) (((char *) &et) + offset) */ + + t = convert (string_type_node, /* (char *) */ + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (et)), + et)); + t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t), + t, + build_int_2 (offset, 0)); + t = convert (build_pointer_type (type), + t); + + addr = TRUE; + + resume_momentary (yes); + } + else + { + tree initexpr; + bool init = ffesymbol_is_init (s); + + yes = suspend_momentary (); + + t = build_decl (VAR_DECL, + ffecom_get_identifier_ (ffesymbol_text (s)), + type); + + if (init + || ffesymbol_namelisted (s) +#ifdef FFECOM_sizeMAXSTACKITEM + || ((st != NULL) + && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM)) +#endif + || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM) + && (ffecom_primary_entry_kind_ + != FFEINFO_kindBLOCKDATA) + && (ffesymbol_is_save (s) || ffe_is_saveall ()))) + TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE); + else + TREE_STATIC (t) = 0; /* No need to make static. */ + + if (init || ffe_is_init_local_zero ()) + DECL_INITIAL (t) = error_mark_node; + + /* Keep -Wunused from complaining about var if it + is used as sfunc arg or DATA implied-DO. */ + if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG) + DECL_IN_SYSTEM_HEADER (t) = 1; + + t = start_decl (t, FALSE); + + if (init) + { + if (ffesymbol_init (s) != NULL) + initexpr = ffecom_expr (ffesymbol_init (s)); + else + initexpr = ffecom_init_zero_ (t); + } + else if (ffe_is_init_local_zero ()) + initexpr = ffecom_init_zero_ (t); + else + initexpr = NULL_TREE; /* Not ref'd if !init. */ + + finish_decl (t, initexpr, FALSE); + + if ((st != NULL) && (DECL_SIZE (t) != error_mark_node)) + { + tree size_tree; + + size_tree = size_binop (CEIL_DIV_EXPR, + DECL_SIZE (t), + size_int (BITS_PER_UNIT)); + assert (TREE_INT_CST_HIGH (size_tree) == 0); + assert (TREE_INT_CST_LOW (size_tree) == ffestorag_size (st)); + } + + resume_momentary (yes); + } + } + break; + + case FFEINFO_whereRESULT: + assert (!ffecom_transform_only_dummies_); + + if (bt == FFEINFO_basictypeCHARACTER) + { /* Result is already in list of dummies, use + it (& length). */ + t = ffecom_func_result_; + tlen = ffecom_func_length_; + addr = TRUE; + break; + } + if ((ffecom_num_entrypoints_ == 0) + && (bt == FFEINFO_basictypeCOMPLEX) + && (ffesymbol_is_f2c (ffecom_primary_entry_))) + { /* Result is already in list of dummies, use + it. */ + t = ffecom_func_result_; + addr = TRUE; + break; + } + if (ffecom_func_result_ != NULL_TREE) + { + t = ffecom_func_result_; + break; + } + if ((ffecom_num_entrypoints_ != 0) + && (ffecom_master_bt_ == FFEINFO_basictypeNONE)) + { + yes = suspend_momentary (); + + assert (ffecom_multi_retval_ != NULL_TREE); + t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_, + ffecom_multi_retval_); + t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt], + t, ffecom_multi_fields_[bt][kt]); + + resume_momentary (yes); + break; + } + + yes = suspend_momentary (); + + t = build_decl (VAR_DECL, + ffecom_get_identifier_ (ffesymbol_text (s)), + ffecom_tree_type[bt][kt]); + TREE_STATIC (t) = 0; /* Put result on stack. */ + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); + + ffecom_func_result_ = t; + + resume_momentary (yes); + break; + + case FFEINFO_whereDUMMY: + { + tree type; + ffebld dl; + ffebld dim; + tree low; + tree high; + tree old_sizes; + bool adjustable = FALSE; /* Conditionally adjustable? */ + + type = ffecom_tree_type[bt][kt]; + if (ffesymbol_sfdummyparent (s) != NULL) + { + if (current_function_decl == ffecom_outer_function_decl_) + { /* Exec transition before sfunc + context; get it later. */ + break; + } + t = ffecom_get_identifier_ (ffesymbol_text + (ffesymbol_sfdummyparent (s))); + } + else + t = ffecom_get_identifier_ (ffesymbol_text (s)); + + assert (ffecom_transform_only_dummies_); + + old_sizes = get_pending_sizes (); + put_pending_sizes (old_sizes); + + if (bt == FFEINFO_basictypeCHARACTER) + tlen = ffecom_char_enhance_arg_ (&type, s); + type = ffecom_check_size_overflow_ (s, type, TRUE); + + for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl)) + { + if (type == error_mark_node) + break; + + dim = ffebld_head (dl); + assert (ffebld_op (dim) == FFEBLD_opBOUNDS); + if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_) + low = ffecom_integer_one_node; + else + low = ffecom_expr (ffebld_left (dim)); + assert (ffebld_right (dim) != NULL); + if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR) + || ffecom_doing_entry_) + /* Used to just do high=low. But for ffecom_tree_ + canonize_ref_, it probably is important to correctly + assess the size. E.g. given COMPLEX C(*),CFUNC and + C(2)=CFUNC(C), overlap can happen, while it can't + for, say, C(1)=CFUNC(C(2)). */ + high = convert (TREE_TYPE (low), + TYPE_MAX_VALUE (TREE_TYPE (low))); + else + high = ffecom_expr (ffebld_right (dim)); + + /* Determine whether array is conditionally adjustable, + to decide whether back-end magic is needed. + + Normally the front end uses the back-end function + variable_size to wrap SAVE_EXPR's around expressions + affecting the size/shape of an array so that the + size/shape info doesn't change during execution + of the compiled code even though variables and + functions referenced in those expressions might. + + variable_size also makes sure those saved expressions + get evaluated immediately upon entry to the + compiled procedure -- the front end normally doesn't + have to worry about that. + + However, there is a problem with this that affects + g77's implementation of entry points, and that is + that it is _not_ true that each invocation of the + compiled procedure is permitted to evaluate + array size/shape info -- because it is possible + that, for some invocations, that info is invalid (in + which case it is "promised" -- i.e. a violation of + the Fortran standard -- that the compiled code + won't reference the array or its size/shape + during that particular invocation). + + To phrase this in C terms, consider this gcc function: + + void foo (int *n, float (*a)[*n]) + { + // a is "pointer to array ...", fyi. + } + + Suppose that, for some invocations, it is permitted + for a caller of foo to do this: + + foo (NULL, NULL); + + Now the _written_ code for foo can take such a call + into account by either testing explicitly for whether + (a == NULL) || (n == NULL) -- presumably it is + not permitted to reference *a in various fashions + if (n == NULL) I suppose -- or it can avoid it by + looking at other info (other arguments, static/global + data, etc.). + + However, this won't work in gcc 2.5.8 because it'll + automatically emit the code to save the "*n" + expression, which'll yield a NULL dereference for + the "foo (NULL, NULL)" call, something the code + for foo cannot prevent. + + g77 definitely needs to avoid executing such + code anytime the pointer to the adjustable array + is NULL, because even if its bounds expressions + don't have any references to possible "absent" + variables like "*n" -- say all variable references + are to COMMON variables, i.e. global (though in C, + local static could actually make sense) -- the + expressions could yield other run-time problems + for allowably "dead" values in those variables. + + For example, let's consider a more complicated + version of foo: + + extern int i; + extern int j; + + void foo (float (*a)[i/j]) + { + ... + } + + The above is (essentially) quite valid for Fortran + but, again, for a call like "foo (NULL);", it is + permitted for i and j to be undefined when the + call is made. If j happened to be zero, for + example, emitting the code to evaluate "i/j" + could result in a run-time error. + + Offhand, though I don't have my F77 or F90 + standards handy, it might even be valid for a + bounds expression to contain a function reference, + in which case I doubt it is permitted for an + implementation to invoke that function in the + Fortran case involved here (invocation of an + alternate ENTRY point that doesn't have the adjustable + array as one of its arguments). + + So, the code that the compiler would normally emit + to preevaluate the size/shape info for an + adjustable array _must not_ be executed at run time + in certain cases. Specifically, for Fortran, + the case is when the pointer to the adjustable + array == NULL. (For gnu-ish C, it might be nice + for the source code itself to specify an expression + that, if TRUE, inhibits execution of the code. Or + reverse the sense for elegance.) + + (Note that g77 could use a different test than NULL, + actually, since it happens to always pass an + integer to the called function that specifies which + entry point is being invoked. Hmm, this might + solve the next problem.) + + One way a user could, I suppose, write "foo" so + it works is to insert COND_EXPR's for the + size/shape info so the dangerous stuff isn't + actually done, as in: + + void foo (int *n, float (*a)[(a == NULL) ? 0 : *n]) + { + ... + } + + The next problem is that the front end needs to + be able to tell the back end about the array's + decl _before_ it tells it about the conditional + expression to inhibit evaluation of size/shape info, + as shown above. + + To solve this, the front end needs to be able + to give the back end the expression to inhibit + generation of the preevaluation code _after_ + it makes the decl for the adjustable array. + + Until then, the above example using the COND_EXPR + doesn't pass muster with gcc because the "(a == NULL)" + part has a reference to "a", which is still + undefined at that point. + + g77 will therefore use a different mechanism in the + meantime. */ + + if (!adjustable + && ((TREE_CODE (low) != INTEGER_CST) + || (TREE_CODE (high) != INTEGER_CST))) + adjustable = TRUE; + +#if 0 /* Old approach -- see below. */ + if (TREE_CODE (low) != INTEGER_CST) + low = ffecom_3 (COND_EXPR, integer_type_node, + ffecom_adjarray_passed_ (s), + low, + ffecom_integer_zero_node); + + if (TREE_CODE (high) != INTEGER_CST) + high = ffecom_3 (COND_EXPR, integer_type_node, + ffecom_adjarray_passed_ (s), + high, + ffecom_integer_zero_node); +#endif + + /* ~~~gcc/stor-layout.c/layout_type should do this, + probably. Fixes 950302-1.f. */ + + if (TREE_CODE (low) != INTEGER_CST) + low = variable_size (low); + + /* ~~~similarly, this fixes dumb0.f. The C front end + does this, which is why dumb0.c would work. */ + + if (TREE_CODE (high) != INTEGER_CST) + high = variable_size (high); + + type + = build_array_type + (type, + build_range_type (ffecom_integer_type_node, + low, high)); + type = ffecom_check_size_overflow_ (s, type, TRUE); + } + + if (type == error_mark_node) + { + t = error_mark_node; + break; + } + + if ((ffesymbol_sfdummyparent (s) == NULL) + || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)) + { + type = build_pointer_type (type); + addr = TRUE; + } + + 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. */ + + if (ffesymbol_numentries (s) + == (ffecom_num_entrypoints_ + 1)) + break; + +#if 1 + + /* If variable_size in stor-layout has been called during + the above, then get_pending_sizes should have the + yet-to-be-evaluated saved expressions pending. + Make the whole lot of them get emitted, conditionally + on whether the array decl ("t" above) is not NULL. */ + + { + tree sizes = get_pending_sizes (); + tree tem; + + for (tem = sizes; + tem != old_sizes; + tem = TREE_CHAIN (tem)) + { + tree temv = TREE_VALUE (tem); + + if (sizes == tem) + sizes = temv; + else + sizes + = ffecom_2 (COMPOUND_EXPR, + TREE_TYPE (sizes), + temv, + sizes); + } + + if (sizes != tem) + { + sizes + = ffecom_3 (COND_EXPR, + TREE_TYPE (sizes), + ffecom_2 (NE_EXPR, + integer_type_node, + t, + null_pointer_node), + sizes, + convert (TREE_TYPE (sizes), + integer_zero_node)); + sizes = ffecom_save_tree (sizes); + + sizes + = tree_cons (NULL_TREE, sizes, tem); + } + + if (sizes) + put_pending_sizes (sizes); + } + +#else +#if 0 + if (adjustable + && (ffesymbol_numentries (s) + != ffecom_num_entrypoints_ + 1)) + DECL_SOMETHING (t) + = ffecom_2 (NE_EXPR, integer_type_node, + t, + null_pointer_node); +#else +#if 0 + if (adjustable + && (ffesymbol_numentries (s) + != ffecom_num_entrypoints_ + 1)) + { + ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED); + ffebad_here (0, ffesymbol_where_line (s), + ffesymbol_where_column (s)); + ffebad_string (ffesymbol_text (s)); + ffebad_finish (); + } +#endif +#endif +#endif + } + break; + + case FFEINFO_whereCOMMON: + { + ffesymbol cs; + ffeglobal cg; + tree ct; + ffestorag st = ffesymbol_storage (s); + tree type; + int yes; + + cs = ffesymbol_common (s); /* The COMMON area itself. */ + if (st != NULL) /* Else not laid out. */ + { + ffecom_transform_common_ (cs); + st = ffesymbol_storage (s); + } + + yes = suspend_momentary (); + + type = ffecom_type_localvar_ (s, bt, kt); + + cg = ffesymbol_global (cs); /* The global COMMON info. */ + if ((cg == NULL) + || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON)) + ct = NULL_TREE; + else + ct = ffeglobal_hook (cg); /* The common area's tree. */ + + if ((ct == NULL_TREE) + || (st == NULL) + || (type == error_mark_node)) + t = error_mark_node; + else + { + ffetargetOffset offset; + ffestorag cst; + + cst = ffestorag_parent (st); + assert (cst == ffesymbol_storage (cs)); + + offset = ffestorag_modulo (cst) + + ffestorag_offset (st) + - ffestorag_offset (cst); + + ffecom_debug_kludge_ (ct, "COMMON", s, type, offset); + + /* (t_type *) (((char *) &ct) + offset) */ + + t = convert (string_type_node, /* (char *) */ + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (ct)), + ct)); + t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t), + t, + build_int_2 (offset, 0)); + t = convert (build_pointer_type (type), + t); + + addr = TRUE; + } + + resume_momentary (yes); + } + break; + + case FFEINFO_whereIMMEDIATE: + case FFEINFO_whereGLOBAL: + case FFEINFO_whereFLEETING: + case FFEINFO_whereFLEETING_CADDR: + case FFEINFO_whereFLEETING_IADDR: + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereCONSTANT_SUBOBJECT: + default: + assert ("ENTITY where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; + + case FFEINFO_kindFUNCTION: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: /* Me. */ + assert (!ffecom_transform_only_dummies_); + t = current_function_decl; + break; + + case FFEINFO_whereGLOBAL: + assert (!ffecom_transform_only_dummies_); + + if (((g = ffesymbol_global (s)) != NULL) + && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)) + && (ffeglobal_hook (g) != NULL_TREE) + && ffe_is_globals ()) + { + t = ffeglobal_hook (g); + break; + } + + push_obstacks_nochange (); + end_temporary_allocation (); + + if (ffesymbol_is_f2c (s) + && (ffesymbol_where (s) != FFEINFO_whereCONSTANT)) + t = ffecom_tree_fun_type[bt][kt]; + else + t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE); + + t = build_decl (FUNCTION_DECL, + ffecom_get_external_identifier_ (s), + t); + DECL_EXTERNAL (t) = 1; + TREE_PUBLIC (t) = 1; + + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); + + if ((g != NULL) + && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) + ffeglobal_set_hook (g, t); + + resume_temporary_allocation (); + pop_obstacks (); + + break; + + case FFEINFO_whereDUMMY: + assert (ffecom_transform_only_dummies_); + + if (ffesymbol_is_f2c (s) + && (ffesymbol_where (s) != FFEINFO_whereCONSTANT)) + t = ffecom_tree_ptr_to_fun_type[bt][kt]; + else + t = build_pointer_type + (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE)); + + t = build_decl (PARM_DECL, + ffecom_get_identifier_ (ffesymbol_text (s)), + t); +#if BUILT_FOR_270 + DECL_ARTIFICIAL (t) = 1; +#endif + addr = TRUE; + break; + + case FFEINFO_whereCONSTANT: /* Statement function. */ + assert (!ffecom_transform_only_dummies_); + t = ffecom_gen_sfuncdef_ (s, bt, kt); + break; + + case FFEINFO_whereINTRINSIC: + assert (!ffecom_transform_only_dummies_); + break; /* Let actual references generate their + decls. */ + + default: + assert ("FUNCTION where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; + + case FFEINFO_kindSUBROUTINE: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: /* Me. */ + assert (!ffecom_transform_only_dummies_); + t = current_function_decl; + break; + + case FFEINFO_whereGLOBAL: + assert (!ffecom_transform_only_dummies_); + + if (((g = ffesymbol_global (s)) != NULL) + && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)) + && (ffeglobal_hook (g) != NULL_TREE) + && ffe_is_globals ()) + { + t = ffeglobal_hook (g); + break; + } + + push_obstacks_nochange (); + end_temporary_allocation (); + + t = build_decl (FUNCTION_DECL, + ffecom_get_external_identifier_ (s), + ffecom_tree_subr_type); + DECL_EXTERNAL (t) = 1; + TREE_PUBLIC (t) = 1; + + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); + + if ((g != NULL) + && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) + || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))) + ffeglobal_set_hook (g, t); + + resume_temporary_allocation (); + pop_obstacks (); + + break; + + case FFEINFO_whereDUMMY: + assert (ffecom_transform_only_dummies_); + + 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; + + case FFEINFO_whereINTRINSIC: + assert (!ffecom_transform_only_dummies_); + break; /* Let actual references generate their + decls. */ + + default: + assert ("SUBROUTINE where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; + + case FFEINFO_kindPROGRAM: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: /* Me. */ + assert (!ffecom_transform_only_dummies_); + t = current_function_decl; + break; + + case FFEINFO_whereCOMMON: + case FFEINFO_whereDUMMY: + case FFEINFO_whereGLOBAL: + case FFEINFO_whereRESULT: + case FFEINFO_whereFLEETING: + case FFEINFO_whereFLEETING_CADDR: + case FFEINFO_whereFLEETING_IADDR: + case FFEINFO_whereIMMEDIATE: + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereCONSTANT: + case FFEINFO_whereCONSTANT_SUBOBJECT: + default: + assert ("PROGRAM where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; + + case FFEINFO_kindBLOCKDATA: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: /* Me. */ + assert (!ffecom_transform_only_dummies_); + t = current_function_decl; + break; + + case FFEINFO_whereGLOBAL: + assert (!ffecom_transform_only_dummies_); + + push_obstacks_nochange (); + end_temporary_allocation (); + + t = build_decl (FUNCTION_DECL, + ffecom_get_external_identifier_ (s), + ffecom_tree_blockdata_type); + DECL_EXTERNAL (t) = 1; + TREE_PUBLIC (t) = 1; + + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); + + resume_temporary_allocation (); + pop_obstacks (); + + break; + + case FFEINFO_whereCOMMON: + case FFEINFO_whereDUMMY: + case FFEINFO_whereRESULT: + case FFEINFO_whereFLEETING: + case FFEINFO_whereFLEETING_CADDR: + case FFEINFO_whereFLEETING_IADDR: + case FFEINFO_whereIMMEDIATE: + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereCONSTANT: + case FFEINFO_whereCONSTANT_SUBOBJECT: + default: + assert ("BLOCKDATA where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; + + case FFEINFO_kindCOMMON: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: + assert (!ffecom_transform_only_dummies_); + ffecom_transform_common_ (s); + break; + + case FFEINFO_whereNONE: + case FFEINFO_whereCOMMON: + case FFEINFO_whereDUMMY: + case FFEINFO_whereGLOBAL: + case FFEINFO_whereRESULT: + case FFEINFO_whereFLEETING: + case FFEINFO_whereFLEETING_CADDR: + case FFEINFO_whereFLEETING_IADDR: + case FFEINFO_whereIMMEDIATE: + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereCONSTANT: + case FFEINFO_whereCONSTANT_SUBOBJECT: + default: + assert ("COMMON where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; + + case FFEINFO_kindCONSTRUCT: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: + assert (!ffecom_transform_only_dummies_); + break; + + case FFEINFO_whereNONE: + case FFEINFO_whereCOMMON: + case FFEINFO_whereDUMMY: + case FFEINFO_whereGLOBAL: + case FFEINFO_whereRESULT: + case FFEINFO_whereFLEETING: + case FFEINFO_whereFLEETING_CADDR: + case FFEINFO_whereFLEETING_IADDR: + case FFEINFO_whereIMMEDIATE: + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereCONSTANT: + case FFEINFO_whereCONSTANT_SUBOBJECT: + default: + assert ("CONSTRUCT where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; + + case FFEINFO_kindNAMELIST: + switch (ffeinfo_where (ffesymbol_info (s))) + { + case FFEINFO_whereLOCAL: + assert (!ffecom_transform_only_dummies_); + t = ffecom_transform_namelist_ (s); + break; + + case FFEINFO_whereNONE: + case FFEINFO_whereCOMMON: + case FFEINFO_whereDUMMY: + case FFEINFO_whereGLOBAL: + case FFEINFO_whereRESULT: + case FFEINFO_whereFLEETING: + case FFEINFO_whereFLEETING_CADDR: + case FFEINFO_whereFLEETING_IADDR: + case FFEINFO_whereIMMEDIATE: + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereCONSTANT: + case FFEINFO_whereCONSTANT_SUBOBJECT: + default: + assert ("NAMELIST where unheard of" == NULL); + /* Fall through. */ + case FFEINFO_whereANY: + t = error_mark_node; + break; + } + break; + + default: + assert ("kind unheard of" == NULL); + /* Fall through. */ + case FFEINFO_kindANY: + t = error_mark_node; + break; + } + + ffesymbol_hook (s).decl_tree = t; + ffesymbol_hook (s).length_tree = tlen; + ffesymbol_hook (s).addr = addr; + + lineno = old_lineno; + input_filename = old_input_filename; + + return s; +} + +#endif +/* Transform into ASSIGNable symbol. + + Symbol has already been transformed, but for whatever reason, the + resulting decl_tree has been deemed not usable for an ASSIGN target. + (E.g. it isn't wide enough to hold a pointer.) So, here we invent + 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) +{ + tree t; /* Transformed thingy. */ + int yes; + int old_lineno = lineno; + char *old_input_filename = input_filename; + + if (ffesymbol_sfdummyparent (s) == NULL) + { + input_filename = ffesymbol_where_filename (s); + lineno = ffesymbol_where_filelinenum (s); + } + else + { + ffesymbol sf = ffesymbol_sfdummyparent (s); + + input_filename = ffesymbol_where_filename (sf); + lineno = ffesymbol_where_filelinenum (sf); + } + + assert (!ffecom_transform_only_dummies_); + + yes = suspend_momentary (); + + t = build_decl (VAR_DECL, + ffecom_get_invented_identifier ("__g77_ASSIGN_%s", + ffesymbol_text (s), + 0), + TREE_TYPE (null_pointer_node)); + + switch (ffesymbol_where (s)) + { + case FFEINFO_whereLOCAL: + /* Unlike for regular vars, SAVE status is easy to determine for + ASSIGNed vars, since there's no initialization, there's no + effective storage association (so "SAVE J" does not apply to + K even given "EQUIVALENCE (J,K)"), there's no size issue + to worry about, etc. */ + if ((ffesymbol_is_save (s) || ffe_is_saveall ()) + && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM) + && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)) + TREE_STATIC (t) = 1; /* SAVEd in proc, make static. */ + else + TREE_STATIC (t) = 0; /* No need to make static. */ + break; + + case FFEINFO_whereCOMMON: + TREE_STATIC (t) = 1; /* Assume COMMONs always SAVEd. */ + break; + + case FFEINFO_whereDUMMY: + /* Note that twinning a DUMMY means the caller won't see + the ASSIGNed value. But both F77 and F90 allow implementations + to do this, i.e. disallow Fortran code that would try and + take advantage of actually putting a label into a variable + via a dummy argument (or any other storage association, for + that matter). */ + TREE_STATIC (t) = 0; + break; + + default: + TREE_STATIC (t) = 0; + break; + } + + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); + + resume_momentary (yes); + + ffesymbol_hook (s).assign_tree = t; + + lineno = old_lineno; + input_filename = old_input_filename; + + return s; +} + +#endif +/* Implement COMMON area in back end. + + Because COMMON-based variables can be referenced in the dimension + expressions of dummy (adjustable) arrays, and because dummies + (in the gcc back end) need to be put in the outer binding level + of a function (which has two binding levels, the outer holding + the dummies and the inner holding the other vars), special care + must be taken to handle COMMON areas. + + The current strategy is basically to always tell the back end about + the COMMON area as a top-level external reference to just a block + of storage of the master type of that area (e.g. integer, real, + character, whatever -- not a structure). As a distinct action, + if initial values are provided, tell the back end about the area + as a top-level non-external (initialized) area and remember not to + allow further initialization or expansion of the area. Meanwhile, + if no initialization happens at all, tell the back end about + the largest size we've seen declared so the space does get reserved. + (This function doesn't handle all that stuff, but it does some + of the important things.) + + Meanwhile, for COMMON variables themselves, just keep creating + references like *((float *) (&common_area + offset)) each time + we reference the variable. In other words, don't make a VAR_DECL + or any kind of component reference (like we used to do before 0.4), + 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) +{ + ffestorag st = ffesymbol_storage (s); + ffeglobal g = ffesymbol_global (s); + tree cbt; + tree cbtype; + tree init; + bool is_init = ffestorag_is_init (st); + + assert (st != NULL); + + if ((g == NULL) + || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON)) + return; + + /* First update the size of the area in global terms. */ + + ffeglobal_size_common (s, ffestorag_size (st)); + + if (!ffeglobal_common_init (g)) + is_init = FALSE; /* No explicit init, don't let erroneous joins init. */ + + cbt = ffeglobal_hook (g); + + /* If we already have declared this common block for a previous program + unit, and either we already initialized it or we don't have new + initialization for it, just return what we have without changing it. */ + + if ((cbt != NULL_TREE) + && (!is_init + || !DECL_EXTERNAL (cbt))) + return; + + /* Process inits. */ + + if (is_init) + { + if (ffestorag_init (st) != NULL) + { + init = ffecom_expr (ffestorag_init (st)); + if (init == error_mark_node) + { /* Hopefully the back end complained! */ + init = NULL_TREE; + if (cbt != NULL_TREE) + return; + } + } + else + init = error_mark_node; + } + else + init = NULL_TREE; + + push_obstacks_nochange (); + end_temporary_allocation (); + + /* cbtype must be permanently allocated! */ + + if (init) + cbtype = build_array_type (char_type_node, + build_range_type (integer_type_node, + integer_one_node, + build_int_2 + (ffeglobal_common_size (g), + 0))); + else + cbtype = build_array_type (char_type_node, NULL_TREE); + + if (cbt == NULL_TREE) + { + cbt + = build_decl (VAR_DECL, + ffecom_get_external_identifier_ (s), + cbtype); + TREE_STATIC (cbt) = 1; + TREE_PUBLIC (cbt) = 1; + } + else + { + assert (is_init); + TREE_TYPE (cbt) = cbtype; + } + DECL_EXTERNAL (cbt) = init ? 0 : 1; + DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE; + + cbt = start_decl (cbt, TRUE); + if (ffeglobal_hook (g) != NULL) + assert (cbt == ffeglobal_hook (g)); + + assert (!init || !DECL_EXTERNAL (cbt)); + + /* Make sure that any type can live in COMMON and be referenced + without getting a bus error. We could pick the most restrictive + alignment of all entities actually placed in the COMMON, but + this seems easy enough. */ + + DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT; + + if (is_init && (ffestorag_init (st) == NULL)) + init = ffecom_init_zero_ (cbt); + + finish_decl (cbt, init, TRUE); + + if (is_init) + ffestorag_set_init (st, ffebld_new_any ()); + + if (init) + { + tree size_tree; + + assert (DECL_SIZE (cbt) != NULL_TREE); + assert (TREE_CODE (DECL_SIZE (cbt)) == INTEGER_CST); + size_tree = size_binop (CEIL_DIV_EXPR, + DECL_SIZE (cbt), + size_int (BITS_PER_UNIT)); + assert (TREE_INT_CST_HIGH (size_tree) == 0); + assert (TREE_INT_CST_LOW (size_tree) == ffeglobal_common_size (g)); + } + + ffeglobal_set_hook (g, cbt); + + ffestorag_set_hook (st, cbt); + + resume_temporary_allocation (); + pop_obstacks (); +} + +#endif +/* Make master area for local EQUIVALENCE. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffecom_transform_equiv_ (ffestorag eqst) +{ + tree eqt; + tree eqtype; + tree init; + tree high; + bool is_init = ffestorag_is_init (eqst); + int yes; + + assert (eqst != NULL); + + eqt = ffestorag_hook (eqst); + + if (eqt != NULL_TREE) + return; + + /* Process inits. */ + + if (is_init) + { + if (ffestorag_init (eqst) != NULL) + { + init = ffecom_expr (ffestorag_init (eqst)); + if (init == error_mark_node) + init = NULL_TREE; /* Hopefully the back end complained! */ + } + else + init = error_mark_node; + } + else if (ffe_is_init_local_zero ()) + init = error_mark_node; + else + init = NULL_TREE; + + ffecom_member_namelisted_ = FALSE; + ffestorag_drive (ffestorag_list_equivs (eqst), + &ffecom_member_phase1_, + eqst); + + yes = suspend_momentary (); + + high = build_int_2 (ffestorag_size (eqst), 0); + TREE_TYPE (high) = ffecom_integer_type_node; + + eqtype = build_array_type (char_type_node, + build_range_type (ffecom_integer_type_node, + ffecom_integer_one_node, + high)); + + eqt = build_decl (VAR_DECL, + ffecom_get_invented_identifier ("__g77_equiv_%s", + ffesymbol_text + (ffestorag_symbol + (eqst)), + 0), + eqtype); + DECL_EXTERNAL (eqt) = 0; + if (is_init + || ffecom_member_namelisted_ +#ifdef FFECOM_sizeMAXSTACKITEM + || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM) +#endif + || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM) + && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA) + && (ffestorag_is_save (eqst) || ffe_is_saveall ()))) + TREE_STATIC (eqt) = 1; + else + TREE_STATIC (eqt) = 0; + TREE_PUBLIC (eqt) = 0; + DECL_CONTEXT (eqt) = current_function_decl; + if (init) + DECL_INITIAL (eqt) = error_mark_node; + else + DECL_INITIAL (eqt) = NULL_TREE; + + eqt = start_decl (eqt, FALSE); + + /* Make sure this shows up as a debug symbol, which is not normally + the case for invented identifiers. */ + + DECL_IGNORED_P (eqt) = 0; + + /* Make sure that any type can live in EQUIVALENCE and be referenced + without getting a bus error. We could pick the most restrictive + alignment of all entities actually placed in the EQUIVALENCE, but + this seems easy enough. */ + + DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT; + + if ((!is_init && ffe_is_init_local_zero ()) + || (is_init && (ffestorag_init (eqst) == NULL))) + init = ffecom_init_zero_ (eqt); + + finish_decl (eqt, init, FALSE); + + if (is_init) + ffestorag_set_init (eqst, ffebld_new_any ()); + + { + tree size_tree; + + size_tree = size_binop (CEIL_DIV_EXPR, + DECL_SIZE (eqt), + size_int (BITS_PER_UNIT)); + assert (TREE_INT_CST_HIGH (size_tree) == 0); + assert (TREE_INT_CST_LOW (size_tree) == ffestorag_size (eqst)); + } + + ffestorag_set_hook (eqst, eqt); + +#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING + ffestorag_drive (ffestorag_list_equivs (eqst), + &ffecom_member_phase2_, + eqst); +#endif + + resume_momentary (yes); +} + +#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) +{ + tree nmlt; + tree nmltype = ffecom_type_namelist_ (); + tree nmlinits; + tree nameinit; + tree varsinit; + tree nvarsinit; + tree field; + tree high; + int yes; + int i; + static int mynumber = 0; + + yes = suspend_momentary (); + + nmlt = build_decl (VAR_DECL, + ffecom_get_invented_identifier ("__g77_namelist_%d", + NULL, mynumber++), + nmltype); + TREE_STATIC (nmlt) = 1; + DECL_INITIAL (nmlt) = error_mark_node; + + nmlt = start_decl (nmlt, FALSE); + + /* Process inits. */ + + i = strlen (ffesymbol_text (s)); + + high = build_int_2 (i, 0); + TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node; + + nameinit = ffecom_build_f2c_string_ (i + 1, + ffesymbol_text (s)); + TREE_TYPE (nameinit) + = build_type_variant + (build_array_type + (char_type_node, + build_range_type (ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + high)), + 1, 0); + TREE_CONSTANT (nameinit) = 1; + TREE_STATIC (nameinit) = 1; + nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)), + nameinit); + + varsinit = ffecom_vardesc_array_ (s); + varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)), + varsinit); + TREE_CONSTANT (varsinit) = 1; + TREE_STATIC (varsinit) = 1; + + { + ffebld b; + + for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b)) + ++i; + } + nvarsinit = build_int_2 (i, 0); + TREE_TYPE (nvarsinit) = integer_type_node; + TREE_CONSTANT (nvarsinit) = 1; + TREE_STATIC (nvarsinit) = 1; + + nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit); + TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)), + varsinit); + TREE_CHAIN (TREE_CHAIN (nmlinits)) + = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit); + + nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits); + TREE_CONSTANT (nmlinits) = 1; + TREE_STATIC (nmlinits) = 1; + + finish_decl (nmlt, nmlinits, FALSE); + + nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt); + + resume_momentary (yes); + + 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) +{ + switch (TREE_CODE (t)) + { + case NOP_EXPR: + case CONVERT_EXPR: + case NON_LVALUE_EXPR: + ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0)); + break; + + case PLUS_EXPR: + ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0)); + if ((*decl == NULL_TREE) + || (*decl == error_mark_node)) + break; + + if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST) + { + /* An offset into COMMON. */ + *offset = size_binop (PLUS_EXPR, + *offset, + TREE_OPERAND (t, 1)); + /* Convert offset (presumably in bytes) into canonical units + (presumably bits). */ + *offset = size_binop (MULT_EXPR, + *offset, + TYPE_SIZE (TREE_TYPE (TREE_TYPE (t)))); + break; + } + /* Not a COMMON reference, so an unrecognized pattern. */ + *decl = error_mark_node; + break; + + case PARM_DECL: + *decl = t; + *offset = size_zero_node; + break; + + case ADDR_EXPR: + if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL) + { + /* A reference to COMMON. */ + *decl = TREE_OPERAND (t, 0); + *offset = size_zero_node; + break; + } + /* Fall through. */ + default: + /* Not a COMMON reference, so an unrecognized pattern. */ + *decl = error_mark_node; + 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 + offset into that decl, and a size for the lvalue. + + If there's no applicable decl, NULL_TREE is returned for the decl, + and the other fields are left undefined. + + If the tree doesn't fit the recognizable forms, an ERROR_MARK node + is returned for the decl, and the other fields are left undefined. + + Otherwise, the decl returned currently is either a VAR_DECL or a + PARM_DECL. + + The offset returned is always valid, but of course not necessarily + a constant, and not necessarily converted into the appropriate + type, leaving that up to the caller (so as to avoid that overhead + if the decls being looked at are different anyway). + + If the size cannot be determined (e.g. an adjustable array), + an ERROR_MARK node is returned for the size. Otherwise, the + size returned is valid, not necessarily a constant, and not + necessarily converted into the appropriate type as with the + offset. + + Note that the offset and size expressions are expressed in the + base storage units (usually bits) rather than in the units of + the type of the decl, because two decls with different types + might overlap but with apparently non-overlapping array offsets, + 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) +{ + /* The default path is to report a nonexistant decl. */ + *decl = NULL_TREE; + + if (t == NULL_TREE) + return; + + switch (TREE_CODE (t)) + { + case ERROR_MARK: + case IDENTIFIER_NODE: + case INTEGER_CST: + case REAL_CST: + case COMPLEX_CST: + case STRING_CST: + case CONST_DECL: + case PLUS_EXPR: + case MINUS_EXPR: + case MULT_EXPR: + case TRUNC_DIV_EXPR: + case CEIL_DIV_EXPR: + case FLOOR_DIV_EXPR: + case ROUND_DIV_EXPR: + case TRUNC_MOD_EXPR: + case CEIL_MOD_EXPR: + case FLOOR_MOD_EXPR: + case ROUND_MOD_EXPR: + case RDIV_EXPR: + case EXACT_DIV_EXPR: + case FIX_TRUNC_EXPR: + case FIX_CEIL_EXPR: + case FIX_FLOOR_EXPR: + case FIX_ROUND_EXPR: + case FLOAT_EXPR: + case EXPON_EXPR: + case NEGATE_EXPR: + case MIN_EXPR: + case MAX_EXPR: + case ABS_EXPR: + case FFS_EXPR: + case LSHIFT_EXPR: + case RSHIFT_EXPR: + case LROTATE_EXPR: + case RROTATE_EXPR: + case BIT_IOR_EXPR: + case BIT_XOR_EXPR: + case BIT_AND_EXPR: + case BIT_ANDTC_EXPR: + case BIT_NOT_EXPR: + case TRUTH_ANDIF_EXPR: + case TRUTH_ORIF_EXPR: + case TRUTH_AND_EXPR: + case TRUTH_OR_EXPR: + case TRUTH_XOR_EXPR: + case TRUTH_NOT_EXPR: + case LT_EXPR: + case LE_EXPR: + case GT_EXPR: + case GE_EXPR: + case EQ_EXPR: + case NE_EXPR: + case COMPLEX_EXPR: + case CONJ_EXPR: + case REALPART_EXPR: + case IMAGPART_EXPR: + case LABEL_EXPR: + case COMPONENT_REF: + case COMPOUND_EXPR: + case ADDR_EXPR: + return; + + case VAR_DECL: + case PARM_DECL: + *decl = t; + *offset = size_zero_node; + *size = TYPE_SIZE (TREE_TYPE (t)); + return; + + case ARRAY_REF: + { + tree array = TREE_OPERAND (t, 0); + tree element = TREE_OPERAND (t, 1); + tree init_offset; + + if ((array == NULL_TREE) + || (element == NULL_TREE)) + { + *decl = error_mark_node; + return; + } + + ffecom_tree_canonize_ref_ (decl, &init_offset, size, + array); + if ((*decl == NULL_TREE) + || (*decl == error_mark_node)) + return; + + *offset = size_binop (MULT_EXPR, + TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))), + size_binop (MINUS_EXPR, + element, + TYPE_MIN_VALUE + (TYPE_DOMAIN + (TREE_TYPE (array))))); + + *offset = size_binop (PLUS_EXPR, + init_offset, + *offset); + + *size = TYPE_SIZE (TREE_TYPE (t)); + return; + } + + case INDIRECT_REF: + + /* Most of this code is to handle references to COMMON. And so + far that is useful only for calling library functions, since + external (user) functions might reference common areas. But + even calling an external function, it's worthwhile to decode + COMMON references because if not storing into COMMON, we don't + want COMMON-based arguments to gratuitously force use of a + temporary. */ + + *size = TYPE_SIZE (TREE_TYPE (t)); + + ffecom_tree_canonize_ptr_ (decl, offset, + TREE_OPERAND (t, 0)); + + return; + + case CONVERT_EXPR: + case NOP_EXPR: + case MODIFY_EXPR: + case NON_LVALUE_EXPR: + case RESULT_DECL: + case FIELD_DECL: + case COND_EXPR: /* More cases than we can handle. */ + case SAVE_EXPR: + case REFERENCE_EXPR: + case PREDECREMENT_EXPR: + case PREINCREMENT_EXPR: + case POSTDECREMENT_EXPR: + case POSTINCREMENT_EXPR: + case CALL_EXPR: + default: + *decl = error_mark_node; + 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) +{ + if ((left == error_mark_node) + || (right == error_mark_node)) + return error_mark_node; + + switch (TREE_CODE (tree_type)) + { + case INTEGER_TYPE: + return ffecom_2 (TRUNC_DIV_EXPR, tree_type, + left, + right); + + case COMPLEX_TYPE: + { + ffecomGfrt ix; + + if (TREE_TYPE (tree_type) + == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]) + ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */ + else + ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */ + + left = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (left)), + left); + left = build_tree_list (NULL_TREE, left); + right = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (right)), + right); + right = build_tree_list (NULL_TREE, right); + TREE_CHAIN (left) = right; + + return ffecom_call_ (ffecom_gfrt_tree_ (ix), + ffecom_gfrt_kindtype (ix), + ffe_is_f2c_library (), + tree_type, + left, + dest_tree, dest, dest_used, + NULL_TREE, TRUE); + } + break; + + case RECORD_TYPE: + { + ffecomGfrt ix; + + if (TREE_TYPE (TYPE_FIELDS (tree_type)) + == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]) + ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */ + else + ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */ + + left = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (left)), + left); + left = build_tree_list (NULL_TREE, left); + right = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (right)), + right); + right = build_tree_list (NULL_TREE, right); + TREE_CHAIN (left) = right; + + return ffecom_call_ (ffecom_gfrt_tree_ (ix), + ffecom_gfrt_kindtype (ix), + ffe_is_f2c_library (), + tree_type, + left, + dest_tree, dest, dest_used, + NULL_TREE, TRUE); + } + break; + + default: + return ffecom_2 (RDIV_EXPR, tree_type, + left, + right); + } +} + +#endif +/* ffecom_type_localvar_ -- Build type info for non-dummy variable + + tree type; + ffesymbol s; // the variable's symbol + ffeinfoBasictype bt; // it's basictype + ffeinfoKindtype kt; // it's kindtype + + type = ffecom_type_localvar_(s,bt,kt); + + Handles static arrays, CHARACTER type, etc. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt, + ffeinfoKindtype kt) +{ + tree type; + ffebld dl; + ffebld dim; + tree lowt; + tree hight; + + type = ffecom_tree_type[bt][kt]; + if (bt == FFEINFO_basictypeCHARACTER) + { + hight = build_int_2 (ffesymbol_size (s), 0); + TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node; + + type + = build_array_type + (type, + build_range_type (ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + hight)); + type = ffecom_check_size_overflow_ (s, type, FALSE); + } + + for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl)) + { + if (type == error_mark_node) + break; + + dim = ffebld_head (dl); + assert (ffebld_op (dim) == FFEBLD_opBOUNDS); + + if (ffebld_left (dim) == NULL) + lowt = integer_one_node; + else + lowt = ffecom_expr (ffebld_left (dim)); + + if (TREE_CODE (lowt) != INTEGER_CST) + lowt = variable_size (lowt); + + assert (ffebld_right (dim) != NULL); + hight = ffecom_expr (ffebld_right (dim)); + + if (TREE_CODE (hight) != INTEGER_CST) + hight = variable_size (hight); + + type = build_array_type (type, + build_range_type (ffecom_integer_type_node, + lowt, hight)); + type = ffecom_check_size_overflow_ (s, type, FALSE); + } + + return type; +} + +#endif +/* Build Namelist type. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_type_namelist_ () +{ + static tree type = NULL_TREE; + + if (type == NULL_TREE) + { + static tree namefield, varsfield, nvarsfield; + tree vardesctype; + + vardesctype = ffecom_type_vardesc_ (); + + push_obstacks_nochange (); + end_temporary_allocation (); + + type = make_node (RECORD_TYPE); + + vardesctype = build_pointer_type (build_pointer_type (vardesctype)); + + namefield = ffecom_decl_field (type, NULL_TREE, "name", + string_type_node); + varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype); + nvarsfield = ffecom_decl_field (type, varsfield, "nvars", + integer_type_node); + + TYPE_FIELDS (type) = namefield; + layout_type (type); + + resume_temporary_allocation (); + pop_obstacks (); + } + + return type; +} + +#endif + +/* Make a copy of a type, assuming caller has switched to the permanent + obstacks and that the type is for an aggregate (array) initializer. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC && 0 /* Not used now. */ +static tree +ffecom_type_permanent_copy_ (tree t) +{ + tree domain; + tree max; + + assert (TREE_TYPE (t) != NULL_TREE); + + domain = TYPE_DOMAIN (t); + + assert (TREE_CODE (t) == ARRAY_TYPE); + assert (TREE_PERMANENT (TREE_TYPE (t))); + assert (TREE_PERMANENT (TREE_TYPE (domain))); + assert (TREE_PERMANENT (TYPE_MIN_VALUE (domain))); + + max = TYPE_MAX_VALUE (domain); + if (!TREE_PERMANENT (max)) + { + assert (TREE_CODE (max) == INTEGER_CST); + + max = build_int_2 (TREE_INT_CST_LOW (max), TREE_INT_CST_HIGH (max)); + TREE_TYPE (max) = TREE_TYPE (TYPE_MIN_VALUE (domain)); + } + + return build_array_type (TREE_TYPE (t), + build_range_type (TREE_TYPE (domain), + TYPE_MIN_VALUE (domain), + max)); +} +#endif + +/* Build Vardesc type. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_type_vardesc_ () +{ + static tree type = NULL_TREE; + static tree namefield, addrfield, dimsfield, typefield; + + if (type == NULL_TREE) + { + push_obstacks_nochange (); + end_temporary_allocation (); + + type = make_node (RECORD_TYPE); + + namefield = ffecom_decl_field (type, NULL_TREE, "name", + string_type_node); + addrfield = ffecom_decl_field (type, namefield, "addr", + string_type_node); + dimsfield = ffecom_decl_field (type, addrfield, "dims", + ffecom_f2c_ftnlen_type_node); + typefield = ffecom_decl_field (type, dimsfield, "type", + integer_type_node); + + TYPE_FIELDS (type) = namefield; + layout_type (type); + + resume_temporary_allocation (); + pop_obstacks (); + } + + return type; +} + +#endif + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_vardesc_ (ffebld expr) +{ + ffesymbol s; + + assert (ffebld_op (expr) == FFEBLD_opSYMTER); + s = ffebld_symter (expr); + + if (ffesymbol_hook (s).vardesc_tree == NULL_TREE) + { + int i; + tree vardesctype = ffecom_type_vardesc_ (); + tree var; + tree nameinit; + tree dimsinit; + tree addrinit; + tree typeinit; + tree field; + tree varinits; + int yes; + static int mynumber = 0; + + yes = suspend_momentary (); + + var = build_decl (VAR_DECL, + ffecom_get_invented_identifier ("__g77_vardesc_%d", + NULL, mynumber++), + vardesctype); + TREE_STATIC (var) = 1; + DECL_INITIAL (var) = error_mark_node; + + var = start_decl (var, FALSE); + + /* Process inits. */ + + nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s))) + + 1, + ffesymbol_text (s)); + TREE_TYPE (nameinit) + = build_type_variant + (build_array_type + (char_type_node, + build_range_type (integer_type_node, + integer_one_node, + build_int_2 (i, 0))), + 1, 0); + TREE_CONSTANT (nameinit) = 1; + TREE_STATIC (nameinit) = 1; + nameinit = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (nameinit)), + nameinit); + + addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit); + + dimsinit = ffecom_vardesc_dims_ (s); + + if (typeinit == NULL_TREE) + { + ffeinfoBasictype bt = ffesymbol_basictype (s); + ffeinfoKindtype kt = ffesymbol_kindtype (s); + int tc = ffecom_f2c_typecode (bt, kt); + + assert (tc != -1); + typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0); + } + else + typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit); + + varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)), + nameinit); + TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)), + addrinit); + TREE_CHAIN (TREE_CHAIN (varinits)) + = build_tree_list ((field = TREE_CHAIN (field)), dimsinit); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits))) + = build_tree_list ((field = TREE_CHAIN (field)), typeinit); + + varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits); + TREE_CONSTANT (varinits) = 1; + TREE_STATIC (varinits) = 1; + + finish_decl (var, varinits, FALSE); + + var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var); + + resume_momentary (yes); + + ffesymbol_hook (s).vardesc_tree = var; + } + + return ffesymbol_hook (s).vardesc_tree; +} + +#endif +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_vardesc_array_ (ffesymbol s) +{ + ffebld b; + tree list; + tree item = NULL_TREE; + tree var; + int i; + int yes; + static int mynumber = 0; + + for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s); + b != NULL; + b = ffebld_trail (b), ++i) + { + tree t; + + t = ffecom_vardesc_ (ffebld_head (b)); + + if (list == NULL_TREE) + list = item = build_tree_list (NULL_TREE, t); + else + { + TREE_CHAIN (item) = build_tree_list (NULL_TREE, t); + item = TREE_CHAIN (item); + } + } + + yes = suspend_momentary (); + + item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()), + build_range_type (integer_type_node, + integer_one_node, + build_int_2 (i, 0))); + list = build (CONSTRUCTOR, item, NULL_TREE, list); + TREE_CONSTANT (list) = 1; + TREE_STATIC (list) = 1; + + var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", NULL, + mynumber++); + var = build_decl (VAR_DECL, var, item); + TREE_STATIC (var) = 1; + DECL_INITIAL (var) = error_mark_node; + var = start_decl (var, FALSE); + finish_decl (var, list, FALSE); + + resume_momentary (yes); + + return var; +} + +#endif +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static tree +ffecom_vardesc_dims_ (ffesymbol s) +{ + if (ffesymbol_dims (s) == NULL) + return convert (ffecom_f2c_ptr_to_ftnlen_type_node, + integer_zero_node); + + { + ffebld b; + ffebld e; + tree list; + tree backlist; + tree item = NULL_TREE; + tree var; + int yes; + tree numdim; + tree numelem; + tree baseoff = NULL_TREE; + static int mynumber = 0; + + numdim = build_int_2 ((int) ffesymbol_rank (s), 0); + TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node; + + numelem = ffecom_expr (ffesymbol_arraysize (s)); + TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node; + + list = NULL_TREE; + backlist = NULL_TREE; + for (b = ffesymbol_dims (s), e = ffesymbol_extents (s); + b != NULL; + b = ffebld_trail (b), e = ffebld_trail (e)) + { + tree t; + tree low; + tree back; + + if (ffebld_trail (b) == NULL) + t = NULL_TREE; + else + { + t = convert (ffecom_f2c_ftnlen_type_node, + ffecom_expr (ffebld_head (e))); + + if (list == NULL_TREE) + list = item = build_tree_list (NULL_TREE, t); + else + { + TREE_CHAIN (item) = build_tree_list (NULL_TREE, t); + item = TREE_CHAIN (item); + } + } + + if (ffebld_left (ffebld_head (b)) == NULL) + low = ffecom_integer_one_node; + else + low = ffecom_expr (ffebld_left (ffebld_head (b))); + low = convert (ffecom_f2c_ftnlen_type_node, low); + + back = build_tree_list (low, t); + TREE_CHAIN (back) = backlist; + backlist = back; + } + + for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item)) + { + if (TREE_VALUE (item) == NULL_TREE) + baseoff = TREE_PURPOSE (item); + else + baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + TREE_PURPOSE (item), + ffecom_2 (MULT_EXPR, + ffecom_f2c_ftnlen_type_node, + TREE_VALUE (item), + baseoff)); + } + + /* backlist now dead, along with all TREE_PURPOSEs on it. */ + + baseoff = build_tree_list (NULL_TREE, baseoff); + TREE_CHAIN (baseoff) = list; + + numelem = build_tree_list (NULL_TREE, numelem); + TREE_CHAIN (numelem) = baseoff; + + numdim = build_tree_list (NULL_TREE, numdim); + TREE_CHAIN (numdim) = numelem; + + yes = suspend_momentary (); + + item = build_array_type (ffecom_f2c_ftnlen_type_node, + build_range_type (integer_type_node, + integer_zero_node, + build_int_2 + ((int) ffesymbol_rank (s) + + 2, 0))); + list = build (CONSTRUCTOR, item, NULL_TREE, numdim); + TREE_CONSTANT (list) = 1; + TREE_STATIC (list) = 1; + + var = ffecom_get_invented_identifier ("__g77_dims_%d", NULL, + mynumber++); + var = build_decl (VAR_DECL, var, item); + TREE_STATIC (var) = 1; + DECL_INITIAL (var) = error_mark_node; + var = start_decl (var, FALSE); + finish_decl (var, list, FALSE); + + var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var); + + resume_momentary (yes); + + return var; + } +} + +#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 item; + + if ((node == error_mark_node) + || (type == error_mark_node)) + return error_mark_node; + + if (code == ADDR_EXPR) + { + if (!mark_addressable (node)) + assert ("can't mark_addressable this node!" == NULL); + } + + switch (ffe_is_emulate_complex () ? code : NOP_EXPR) + { + tree realtype; + + case REALPART_EXPR: + item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node))); + break; + + case IMAGPART_EXPR: + item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node)))); + break; + + + case NEGATE_EXPR: + if (TREE_CODE (type) != RECORD_TYPE) + { + item = build1 (code, type, node); + break; + } + node = ffecom_stabilize_aggregate_ (node); + realtype = TREE_TYPE (TYPE_FIELDS (type)); + item = + ffecom_2 (COMPLEX_EXPR, type, + ffecom_1 (NEGATE_EXPR, realtype, + ffecom_1 (REALPART_EXPR, realtype, + node)), + ffecom_1 (NEGATE_EXPR, realtype, + ffecom_1 (IMAGPART_EXPR, realtype, + node))); + break; + + default: + item = build1 (code, type, node); + break; + } + + if (TREE_SIDE_EFFECTS (node)) + TREE_SIDE_EFFECTS (item) = 1; + if ((code == ADDR_EXPR) && staticp (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, + does not set TREE_ADDRESSABLE (because calling an inline + function does not mean the function needs to be separately + compiled). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_1_fn (tree node) +{ + tree item; + tree type; + + if (node == error_mark_node) + return error_mark_node; + + type = build_type_variant (TREE_TYPE (node), + TREE_READONLY (node), + TREE_THIS_VOLATILE (node)); + item = build1 (ADDR_EXPR, + build_pointer_type (type), node); + if (TREE_SIDE_EFFECTS (node)) + TREE_SIDE_EFFECTS (item) = 1; + if (staticp (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) +{ + tree item; + + if ((node1 == error_mark_node) + || (node2 == error_mark_node) + || (type == error_mark_node)) + return error_mark_node; + + switch (ffe_is_emulate_complex () ? code : NOP_EXPR) + { + tree a, b, c, d, realtype; + + case CONJ_EXPR: + assert ("no CONJ_EXPR support yet" == NULL); + return error_mark_node; + + case COMPLEX_EXPR: + item = build_tree_list (TYPE_FIELDS (type), node1); + TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2); + item = build (CONSTRUCTOR, type, NULL_TREE, item); + break; + + case PLUS_EXPR: + if (TREE_CODE (type) != RECORD_TYPE) + { + item = build (code, type, node1, node2); + break; + } + node1 = ffecom_stabilize_aggregate_ (node1); + node2 = ffecom_stabilize_aggregate_ (node2); + realtype = TREE_TYPE (TYPE_FIELDS (type)); + item = + ffecom_2 (COMPLEX_EXPR, type, + ffecom_2 (PLUS_EXPR, realtype, + ffecom_1 (REALPART_EXPR, realtype, + node1), + ffecom_1 (REALPART_EXPR, realtype, + node2)), + ffecom_2 (PLUS_EXPR, realtype, + ffecom_1 (IMAGPART_EXPR, realtype, + node1), + ffecom_1 (IMAGPART_EXPR, realtype, + node2))); + break; + + case MINUS_EXPR: + if (TREE_CODE (type) != RECORD_TYPE) + { + item = build (code, type, node1, node2); + break; + } + node1 = ffecom_stabilize_aggregate_ (node1); + node2 = ffecom_stabilize_aggregate_ (node2); + realtype = TREE_TYPE (TYPE_FIELDS (type)); + item = + ffecom_2 (COMPLEX_EXPR, type, + ffecom_2 (MINUS_EXPR, realtype, + ffecom_1 (REALPART_EXPR, realtype, + node1), + ffecom_1 (REALPART_EXPR, realtype, + node2)), + ffecom_2 (MINUS_EXPR, realtype, + ffecom_1 (IMAGPART_EXPR, realtype, + node1), + ffecom_1 (IMAGPART_EXPR, realtype, + node2))); + break; + + case MULT_EXPR: + if (TREE_CODE (type) != RECORD_TYPE) + { + item = build (code, type, node1, node2); + break; + } + node1 = ffecom_stabilize_aggregate_ (node1); + node2 = ffecom_stabilize_aggregate_ (node2); + realtype = TREE_TYPE (TYPE_FIELDS (type)); + a = save_expr (ffecom_1 (REALPART_EXPR, realtype, + node1)); + b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype, + node1)); + c = save_expr (ffecom_1 (REALPART_EXPR, realtype, + node2)); + d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype, + node2)); + item = + ffecom_2 (COMPLEX_EXPR, type, + ffecom_2 (MINUS_EXPR, realtype, + ffecom_2 (MULT_EXPR, realtype, + a, + c), + ffecom_2 (MULT_EXPR, realtype, + b, + d)), + ffecom_2 (PLUS_EXPR, realtype, + ffecom_2 (MULT_EXPR, realtype, + a, + d), + ffecom_2 (MULT_EXPR, realtype, + c, + b))); + break; + + case EQ_EXPR: + if ((TREE_CODE (node1) != RECORD_TYPE) + && (TREE_CODE (node2) != RECORD_TYPE)) + { + item = build (code, type, node1, node2); + break; + } + assert (TREE_CODE (node1) == RECORD_TYPE); + assert (TREE_CODE (node2) == RECORD_TYPE); + node1 = ffecom_stabilize_aggregate_ (node1); + node2 = ffecom_stabilize_aggregate_ (node2); + realtype = TREE_TYPE (TYPE_FIELDS (type)); + item = + ffecom_2 (TRUTH_ANDIF_EXPR, type, + ffecom_2 (code, type, + ffecom_1 (REALPART_EXPR, realtype, + node1), + ffecom_1 (REALPART_EXPR, realtype, + node2)), + ffecom_2 (code, type, + ffecom_1 (IMAGPART_EXPR, realtype, + node1), + ffecom_1 (IMAGPART_EXPR, realtype, + node2))); + break; + + case NE_EXPR: + if ((TREE_CODE (node1) != RECORD_TYPE) + && (TREE_CODE (node2) != RECORD_TYPE)) + { + item = build (code, type, node1, node2); + break; + } + assert (TREE_CODE (node1) == RECORD_TYPE); + assert (TREE_CODE (node2) == RECORD_TYPE); + node1 = ffecom_stabilize_aggregate_ (node1); + node2 = ffecom_stabilize_aggregate_ (node2); + realtype = TREE_TYPE (TYPE_FIELDS (type)); + item = + ffecom_2 (TRUTH_ORIF_EXPR, type, + ffecom_2 (code, type, + ffecom_1 (REALPART_EXPR, realtype, + node1), + ffecom_1 (REALPART_EXPR, realtype, + node2)), + ffecom_2 (code, type, + ffecom_1 (IMAGPART_EXPR, realtype, + node1), + ffecom_1 (IMAGPART_EXPR, realtype, + node2))); + break; + + default: + item = build (code, type, node1, node2); + break; + } + + if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)) + TREE_SIDE_EFFECTS (item) = 1; + return fold (item); +} + +#endif +/* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint + + ffesymbol s; // the ENTRY point itself + if (ffecom_2pass_advise_entrypoint(s)) + // the ENTRY point has been accepted + + Does whatever compiler needs to do when it learns about the entrypoint, + like determine the return type of the master function, count the + number of entrypoints, etc. Returns FALSE if the return type is + not compatible with the return type(s) of other entrypoint(s). + + NOTE: for every call to this fn that returns TRUE, _do_entrypoint must + later (after _finish_progunit) be called with the same entrypoint(s) + as passed to this fn for which TRUE was returned. + + 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) +{ + ffebld list; /* opITEM. */ + ffebld mlist; /* opITEM. */ + ffebld plist; /* opITEM. */ + ffebld arg; /* ffebld_head(opITEM). */ + ffebld item; /* opITEM. */ + ffesymbol s; /* ffebld_symter(arg). */ + ffeinfoBasictype bt = ffesymbol_basictype (entry); + ffeinfoKindtype kt = ffesymbol_kindtype (entry); + ffetargetCharacterSize size = ffesymbol_size (entry); + bool ok; + + if (ffecom_num_entrypoints_ == 0) + { /* First entrypoint, make list of main + arglist's dummies. */ + assert (ffecom_primary_entry_ != NULL); + + ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_); + ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_); + ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_); + + for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_); + list != NULL; + list = ffebld_trail (list)) + { + arg = ffebld_head (list); + if (ffebld_op (arg) != FFEBLD_opSYMTER) + continue; /* Alternate return or some such thing. */ + item = ffebld_new_item (arg, NULL); + if (plist == NULL) + ffecom_master_arglist_ = item; + else + ffebld_set_trail (plist, item); + plist = item; + } + } + + /* If necessary, scan entry arglist for alternate returns. Do this scan + apparently redundantly (it's done below to UNIONize the arglists) so + that we don't complain about RETURN 1 if an offending ENTRY is the only + one with an alternate return. */ + + if (!ffecom_is_altreturning_) + { + for (list = ffesymbol_dummyargs (entry); + list != NULL; + list = ffebld_trail (list)) + { + arg = ffebld_head (list); + if (ffebld_op (arg) == FFEBLD_opSTAR) + { + ffecom_is_altreturning_ = TRUE; + break; + } + } + } + + /* Now check type compatibility. */ + + switch (ffecom_master_bt_) + { + case FFEINFO_basictypeNONE: + ok = (bt != FFEINFO_basictypeCHARACTER); + break; + + case FFEINFO_basictypeCHARACTER: + ok + = (bt == FFEINFO_basictypeCHARACTER) + && (kt == ffecom_master_kt_) + && (size == ffecom_master_size_); + break; + + case FFEINFO_basictypeANY: + return FALSE; /* Just don't bother. */ + + default: + if (bt == FFEINFO_basictypeCHARACTER) + { + ok = FALSE; + break; + } + ok = TRUE; + if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_)) + { + ffecom_master_bt_ = FFEINFO_basictypeNONE; + ffecom_master_kt_ = FFEINFO_kindtypeNONE; + } + break; + } + + if (!ok) + { + ffebad_start (FFEBAD_ENTRY_CONFLICTS); + ffest_ffebad_here_current_stmt (0); + ffebad_finish (); + return FALSE; /* Can't handle entrypoint. */ + } + + /* Entrypoint type compatible with previous types. */ + + ++ffecom_num_entrypoints_; + + /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */ + + for (list = ffesymbol_dummyargs (entry); + list != NULL; + list = ffebld_trail (list)) + { + arg = ffebld_head (list); + if (ffebld_op (arg) != FFEBLD_opSYMTER) + continue; /* Alternate return or some such thing. */ + s = ffebld_symter (arg); + for (plist = NULL, mlist = ffecom_master_arglist_; + mlist != NULL; + plist = mlist, mlist = ffebld_trail (mlist)) + { /* plist points to previous item for easy + appending of arg. */ + if (ffebld_symter (ffebld_head (mlist)) == s) + break; /* Already have this arg in the master list. */ + } + if (mlist != NULL) + continue; /* Already have this arg in the master list. */ + + /* Append this arg to the master list. */ + + item = ffebld_new_item (arg, NULL); + if (plist == NULL) + ffecom_master_arglist_ = item; + else + ffebld_set_trail (plist, item); + } + + return TRUE; +} + +#endif +/* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint + + ffesymbol s; // the ENTRY point itself + ffecom_2pass_do_entrypoint(s); + + Does whatever compiler needs to do to make the entrypoint actually + 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) +{ + static int mfn_num = 0; + static int ent_num; + + if (mfn_num != ffecom_num_fns_) + { /* First entrypoint for this program unit. */ + ent_num = 1; + mfn_num = ffecom_num_fns_; + ffecom_do_entry_ (ffecom_primary_entry_, 0); + } + else + ++ent_num; + + --ffecom_num_entrypoints_; + + 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) +{ + tree item; + + if ((node1 == error_mark_node) + || (node2 == error_mark_node) + || (type == error_mark_node)) + return error_mark_node; + + item = build (code, type, node1, node2); + TREE_SIDE_EFFECTS (item) = 1; + 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) +{ + tree item; + + if ((node1 == error_mark_node) + || (node2 == error_mark_node) + || (node3 == error_mark_node) + || (type == error_mark_node)) + return error_mark_node; + + item = build (code, type, node1, node2, node3); + if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2) + || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3))) + TREE_SIDE_EFFECTS (item) = 1; + 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) +{ + tree item; + + if ((node1 == error_mark_node) + || (node2 == error_mark_node) + || (node3 == error_mark_node) + || (type == error_mark_node)) + return error_mark_node; + + item = build (code, type, node1, node2, node3); + TREE_SIDE_EFFECTS (item) = 1; + return fold (item); +} + +#endif +/* ffecom_arg_expr -- Transform argument expr into gcc tree + + See use by ffecom_list_expr. + + If expression is NULL, returns an integer zero tree. If it is not + a CHARACTER expression, returns whatever ffecom_expr + returns and sets the length return value to NULL_TREE. Otherwise + generates code to evaluate the character expression, returns the proper + pointer to the result, but does NOT set the length return value to a tree + that specifies the length of the result. (In other words, the length + variable is always set to NULL_TREE, because a length is never passed.) + + 21-Dec-91 JCB 1.1 + Don't set returned length, since nobody needs it (yet; someday if + we allow CHARACTER*(*) dummies to statement functions, we'll need + it). */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_arg_expr (ffebld expr, tree *length) +{ + tree ign; + + *length = NULL_TREE; + + if (expr == NULL) + return integer_zero_node; + + if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) + return ffecom_expr (expr); + + return ffecom_arg_ptr_to_expr (expr, &ign); +} + +#endif +/* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree + + See use by ffecom_list_ptr_to_expr. + + If expression is NULL, returns an integer zero tree. If it is not + a CHARACTER expression, returns whatever ffecom_ptr_to_expr + returns and sets the length return value to NULL_TREE. Otherwise + generates code to evaluate the character expression, returns the proper + pointer to the result, AND sets the length return value to a tree that + specifies the length of the result. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_arg_ptr_to_expr (ffebld expr, tree *length) +{ + tree item; + tree ign_length; + ffecomConcatList_ catlist; + + *length = NULL_TREE; + + if (expr == NULL) + return integer_zero_node; + + switch (ffebld_op (expr)) + { + case FFEBLD_opPERCENT_VAL: + if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) + return ffecom_expr (ffebld_left (expr)); + { + tree temp_exp; + tree temp_length; + + temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length); + return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)), + temp_exp); + } + + case FFEBLD_opPERCENT_REF: + if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) + return ffecom_ptr_to_expr (ffebld_left (expr)); + ign_length = NULL_TREE; + length = &ign_length; + expr = ffebld_left (expr); + break; + + case FFEBLD_opPERCENT_DESCR: + switch (ffeinfo_basictype (ffebld_info (expr))) + { +#ifdef PASS_HOLLERITH_BY_DESCRIPTOR + case FFEINFO_basictypeHOLLERITH: +#endif + case FFEINFO_basictypeCHARACTER: + break; /* Passed by descriptor anyway. */ + + default: + item = ffecom_ptr_to_expr (expr); + if (item != error_mark_node) + *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item))); + break; + } + break; + + default: + break; + } + +#ifdef PASS_HOLLERITH_BY_DESCRIPTOR + if (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH) + { /* Pass Hollerith by descriptor. */ + ffetargetHollerith h; + + assert (ffebld_op (expr) == FFEBLD_opCONTER); + h = ffebld_cu_val_hollerith (ffebld_constant_union + (ffebld_conter (expr))); + *length + = build_int_2 (h.length, 0); + TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; + } +#endif + + if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER) + return ffecom_ptr_to_expr (expr); + + assert (ffeinfo_kindtype (ffebld_info (expr)) + == FFEINFO_kindtypeCHARACTER1); + + catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE); + switch (ffecom_concat_list_count_ (catlist)) + { + case 0: /* Shouldn't happen, but in case it does... */ + *length = ffecom_f2c_ftnlen_zero_node; + TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node; + ffecom_concat_list_kill_ (catlist); + return null_pointer_node; + + case 1: /* The (fairly) easy case. */ + ffecom_char_args_ (&item, length, + ffecom_concat_list_expr_ (catlist, 0)); + ffecom_concat_list_kill_ (catlist); + assert (item != NULL_TREE); + return item; + + default: /* Must actually concatenate things. */ + break; + } + + { + int count = ffecom_concat_list_count_ (catlist); + int i; + tree lengths; + tree items; + tree length_array; + tree item_array; + tree citem; + tree clength; + tree temporary; + tree num; + tree known_length; + ffetargetCharacterSize sz; + + length_array + = lengths + = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node, + FFETARGET_charactersizeNONE, count, TRUE); + item_array + = items + = ffecom_push_tempvar (ffecom_f2c_address_type_node, + FFETARGET_charactersizeNONE, count, TRUE); + + known_length = ffecom_f2c_ftnlen_zero_node; + + for (i = 0; i < count; ++i) + { + ffecom_char_args_ (&citem, &clength, + ffecom_concat_list_expr_ (catlist, i)); + if ((citem == error_mark_node) + || (clength == error_mark_node)) + { + ffecom_concat_list_kill_ (catlist); + *length = error_mark_node; + return error_mark_node; + } + + items + = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items), + ffecom_modify (void_type_node, + ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))), + item_array, + build_int_2 (i, 0)), + citem), + items); + clength = ffecom_save_tree (clength); + known_length + = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node, + known_length, + clength); + lengths + = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths), + ffecom_modify (void_type_node, + ffecom_2 (ARRAY_REF, + TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))), + length_array, + build_int_2 (i, 0)), + clength), + lengths); + } + + sz = ffecom_concat_list_maxlen_ (catlist); + assert (sz != FFETARGET_charactersizeNONE); + + temporary = ffecom_push_tempvar (char_type_node, + sz, -1, TRUE); + temporary = ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (temporary)), + temporary); + + item = build_tree_list (NULL_TREE, temporary); + TREE_CHAIN (item) + = build_tree_list (NULL_TREE, + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (items)), + items)); + TREE_CHAIN (TREE_CHAIN (item)) + = build_tree_list (NULL_TREE, + ffecom_1 (ADDR_EXPR, + build_pointer_type (TREE_TYPE (lengths)), + lengths)); + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))) + = build_tree_list + (NULL_TREE, + ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node, + convert (ffecom_f2c_ftnlen_type_node, + build_int_2 (count, 0)))); + num = build_int_2 (sz, 0); + TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node; + TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))) + = build_tree_list (NULL_TREE, num); + + item = ffecom_call_gfrt (FFECOM_gfrtCAT, item); + TREE_SIDE_EFFECTS (item) = 1; + item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary), + item, + temporary); + + *length = known_length; + } + + ffecom_concat_list_kill_ (catlist); + assert (item != NULL_TREE); + return item; +} + +#endif +/* ffecom_call_gfrt -- Generate call to run-time function + + tree expr; + expr = ffecom_call_gfrt(FFECOM_gfrtSTOPNIL,NULL_TREE); + + The first arg is the GNU Fortran Run-Time function index, the second + arg is the list of arguments to pass to it. Returned is the expression + (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) +{ + return ffecom_call_ (ffecom_gfrt_tree_ (ix), + ffecom_gfrt_kindtype (ix), + ffe_is_f2c_library () && ffecom_gfrt_complex_[ix], + NULL_TREE, args, NULL_TREE, NULL, + NULL, NULL_TREE, TRUE); +} +#endif + +/* ffecom_constantunion -- Transform constant-union to tree + + ffebldConstantUnion cu; // the constant to transform + ffeinfoBasictype bt; // its basic type + ffeinfoKindtype kt; // its kind type + tree tree_type; // ffecom_tree_type[bt][kt] + ffecom_constantunion(&cu,bt,kt,tree_type); */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt, + ffeinfoKindtype kt, tree tree_type) +{ + tree item; + + switch (bt) + { + case FFEINFO_basictypeINTEGER: + { + int val; + + switch (kt) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + val = ffebld_cu_val_integer1 (*cu); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + val = ffebld_cu_val_integer2 (*cu); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + val = ffebld_cu_val_integer3 (*cu); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + val = ffebld_cu_val_integer4 (*cu); + break; +#endif + + default: + assert ("bad INTEGER constant kind type" == NULL); + /* Fall through. */ + case FFEINFO_kindtypeANY: + return error_mark_node; + } + item = build_int_2 (val, (val < 0) ? -1 : 0); + TREE_TYPE (item) = tree_type; + } + break; + + case FFEINFO_basictypeLOGICAL: + { + int val; + + switch (kt) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + val = ffebld_cu_val_logical1 (*cu); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + val = ffebld_cu_val_logical2 (*cu); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + val = ffebld_cu_val_logical3 (*cu); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + val = ffebld_cu_val_logical4 (*cu); + break; +#endif + + default: + assert ("bad LOGICAL constant kind type" == NULL); + /* Fall through. */ + case FFEINFO_kindtypeANY: + return error_mark_node; + } + item = build_int_2 (val, (val < 0) ? -1 : 0); + TREE_TYPE (item) = tree_type; + } + break; + + case FFEINFO_basictypeREAL: + { + REAL_VALUE_TYPE val; + + switch (kt) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu)); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu)); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu)); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu)); + break; +#endif + + default: + assert ("bad REAL constant kind type" == NULL); + /* Fall through. */ + case FFEINFO_kindtypeANY: + return error_mark_node; + } + item = build_real (tree_type, val); + } + break; + + case FFEINFO_basictypeCOMPLEX: + { + REAL_VALUE_TYPE real; + REAL_VALUE_TYPE imag; + tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt]; + + switch (kt) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real); + imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real); + imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real); + imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real); + imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary); + break; +#endif + + default: + assert ("bad REAL constant kind type" == NULL); + /* Fall through. */ + case FFEINFO_kindtypeANY: + return error_mark_node; + } + item = ffecom_build_complex_constant_ (tree_type, + build_real (el_type, real), + build_real (el_type, imag)); + } + break; + + case FFEINFO_basictypeCHARACTER: + { /* Happens only in DATA and similar contexts. */ + ffetargetCharacter1 val; + + switch (kt) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeLOGICAL1: + val = ffebld_cu_val_character1 (*cu); + break; +#endif + + default: + assert ("bad CHARACTER constant kind type" == NULL); + /* Fall through. */ + case FFEINFO_kindtypeANY: + return error_mark_node; + } + item = build_string (ffetarget_length_character1 (val), + ffetarget_text_character1 (val)); + TREE_TYPE (item) + = build_type_variant (build_array_type (char_type_node, + build_range_type + (integer_type_node, + integer_one_node, + build_int_2 + (ffetarget_length_character1 + (val), 0))), + 1, 0); + } + break; + + case FFEINFO_basictypeHOLLERITH: + { + ffetargetHollerith h; + + h = ffebld_cu_val_hollerith (*cu); + + /* If not at least as wide as default INTEGER, widen it. */ + if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE) + item = build_string (h.length, h.text); + else + { + char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE]; + + memcpy (str, h.text, h.length); + memset (&str[h.length], ' ', + FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE + - h.length); + item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE, + str); + } + TREE_TYPE (item) + = build_type_variant (build_array_type (char_type_node, + build_range_type + (integer_type_node, + integer_one_node, + build_int_2 + (h.length, 0))), + 1, 0); + } + break; + + case FFEINFO_basictypeTYPELESS: + { + ffetargetInteger1 ival; + ffetargetTypeless tless; + ffebad error; + + tless = ffebld_cu_val_typeless (*cu); + error = ffetarget_convert_integer1_typeless (&ival, tless); + assert (error == FFEBAD); + + item = build_int_2 ((int) ival, 0); + } + break; + + default: + assert ("not yet on constant type" == NULL); + /* Fall through. */ + case FFEINFO_basictypeANY: + return error_mark_node; + } + + TREE_CONSTANT (item) = 1; + + return item; +} + +#endif + +/* Handy way to make a field in a struct/union. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_decl_field (tree context, tree prevfield, + char *name, tree type) +{ + tree field; + + field = build_decl (FIELD_DECL, get_identifier (name), type); + DECL_CONTEXT (field) = context; + DECL_FRAME_SIZE (field) = 0; + if (prevfield != NULL_TREE) + TREE_CHAIN (prevfield) = field; + + 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 +} + +/* ffecom_end_transition -- Perform end transition on all symbols + + ffecom_end_transition(); + + Calls ffecom_sym_end_transition for each global and local symbol. */ + +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 (); + ffesymbol_report_all (); + } + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + ffecom_start_progunit_ (); + + for (item = ffecom_list_blockdata_; + item != NULL; + item = ffebld_trail (item)) + { + ffebld callee; + ffesymbol s; + tree dt; + tree t; + tree var; + int yes; + static int number = 0; + + callee = ffebld_head (item); + s = ffebld_symter (callee); + t = ffesymbol_hook (s).decl_tree; + if (t == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + t = ffesymbol_hook (s).decl_tree; + } + + yes = suspend_momentary (); + + dt = build_pointer_type (TREE_TYPE (t)); + + var = build_decl (VAR_DECL, + ffecom_get_invented_identifier ("__g77_forceload_%d", + NULL, number++), + dt); + DECL_EXTERNAL (var) = 0; + TREE_STATIC (var) = 1; + TREE_PUBLIC (var) = 0; + DECL_INITIAL (var) = error_mark_node; + TREE_USED (var) = 1; + + var = start_decl (var, FALSE); + + t = ffecom_1 (ADDR_EXPR, dt, t); + + finish_decl (var, t, FALSE); + + resume_momentary (yes); + } + + /* This handles any COMMON areas that weren't referenced but have, for + example, important initial data. */ + + for (item = ffecom_list_common_; + item != NULL; + item = ffebld_trail (item)) + ffecom_transform_common_ (ffebld_symter (ffebld_head (item))); + + ffecom_list_common_ = NULL; +#endif +} + +/* ffecom_exec_transition -- Perform exec transition on all symbols + + ffecom_exec_transition(); + + Calls ffecom_sym_exec_transition for each global and local symbol. + Make sure error updating not inhibited. */ + +void +ffecom_exec_transition () +{ + bool inhibited; + + if (ffe_is_ffedebug ()) + fprintf (dmpout, "; exec_stmt_transition\n"); + + inhibited = ffebad_inhibit (); + ffebad_set_inhibit (FALSE); + + ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */ + ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */ + if (ffe_is_ffedebug ()) + { + ffestorag_report (); + ffesymbol_report_all (); + } + + if (inhibited) + ffebad_set_inhibit (TRUE); +} + +/* ffecom_expand_let_stmt -- Compile let (assignment) statement + + ffebld dest; + ffebld source; + ffecom_expand_let_stmt(dest,source); + + 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) +{ + tree dest_tree; + tree dest_length; + tree source_tree; + tree expr_tree; + + if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER) + { + bool dest_used; + + dest_tree = ffecom_expr_rw (dest); + if (dest_tree == error_mark_node) + return; + + if ((TREE_CODE (dest_tree) != VAR_DECL) + || TREE_ADDRESSABLE (dest_tree)) + source_tree = ffecom_expr_ (source, dest_tree, dest, + &dest_used, FALSE); + else + { + source_tree = ffecom_expr (source); + dest_used = FALSE; + } + if (source_tree == error_mark_node) + return; + + if (dest_used) + expr_tree = source_tree; + else + expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node, + dest_tree, + source_tree); + + expand_expr_stmt (expr_tree); + return; + } + + ffecom_push_calltemps (); + ffecom_char_args_ (&dest_tree, &dest_length, dest); + ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest), + source); + ffecom_pop_calltemps (); +} + +#endif +/* ffecom_expr -- Transform expr into gcc tree + + tree t; + ffebld expr; // FFE expression. + tree = ffecom_expr(expr); + + 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); +} + +#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); +} + +#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); +} + +#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 (ffebld expr) +{ + assert (expr != NULL); + + return stabilize_reference (ffecom_expr (expr)); +} + +#endif +/* Do global stuff. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_finish_compile () +{ + assert (ffecom_outer_function_decl_ == NULL_TREE); + assert (current_function_decl == NULL_TREE); + + 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) +{ + assert (!is_top_level); + finish_decl (decl, init, FALSE); +} + +#endif +/* Finish a program unit. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_finish_progunit () +{ + ffecom_end_compstmt_ (); + + ffecom_previous_function_decl_ = current_function_decl; + ffecom_which_entrypoint_decl_ = NULL_TREE; + + finish_function (0); +} + +#endif +/* Wrapper for get_identifier. pattern is like "...%s...", text is + inserted into final name in place of "%s", or if text is NULL, + pattern is like "...%d..." and text form of number is inserted + in place of "%d". */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_get_invented_identifier (char *pattern, char *text, int number) +{ + tree decl; + char *nam; + mallocSize lenlen; + char space[66]; + + if (text == NULL) + lenlen = strlen (pattern) + 20; + else + lenlen = strlen (pattern) + strlen (text) - 1; + if (lenlen > ARRAY_SIZE (space)) + nam = malloc_new_ks (malloc_pool_image (), pattern, lenlen); + else + nam = &space[0]; + if (text == NULL) + sprintf (&nam[0], pattern, number); + else + sprintf (&nam[0], pattern, text); + decl = get_identifier (nam); + if (lenlen > ARRAY_SIZE (space)) + malloc_kill_ks (malloc_pool_image (), nam, lenlen); + + IDENTIFIER_INVENTED (decl) = 1; + + return decl; +} + +ffeinfoBasictype +ffecom_gfrt_basictype (ffecomGfrt gfrt) +{ + assert (gfrt < FFECOM_gfrt); + + switch (ffecom_gfrt_type_[gfrt]) + { + case FFECOM_rttypeVOID_: + return FFEINFO_basictypeNONE; + + case FFECOM_rttypeINT_: + return FFEINFO_basictypeINTEGER; + + case FFECOM_rttypeINTEGER_: + return FFEINFO_basictypeINTEGER; + + case FFECOM_rttypeLONGINT_: + return FFEINFO_basictypeINTEGER; + + case FFECOM_rttypeLOGICAL_: + return FFEINFO_basictypeLOGICAL; + + case FFECOM_rttypeREAL_F2C_: + case FFECOM_rttypeREAL_GNU_: + return FFEINFO_basictypeREAL; + + case FFECOM_rttypeCOMPLEX_F2C_: + case FFECOM_rttypeCOMPLEX_GNU_: + return FFEINFO_basictypeCOMPLEX; + + case FFECOM_rttypeDOUBLE_: + return FFEINFO_basictypeREAL; + + case FFECOM_rttypeDBLCMPLX_F2C_: + case FFECOM_rttypeDBLCMPLX_GNU_: + return FFEINFO_basictypeCOMPLEX; + + case FFECOM_rttypeCHARACTER_: + return FFEINFO_basictypeCHARACTER; + + default: + return FFEINFO_basictypeANY; + } +} + +ffeinfoKindtype +ffecom_gfrt_kindtype (ffecomGfrt gfrt) +{ + assert (gfrt < FFECOM_gfrt); + + switch (ffecom_gfrt_type_[gfrt]) + { + case FFECOM_rttypeVOID_: + return FFEINFO_kindtypeNONE; + + case FFECOM_rttypeINT_: + return FFEINFO_kindtypeINTEGER1; + + case FFECOM_rttypeINTEGER_: + return FFEINFO_kindtypeINTEGER1; + + case FFECOM_rttypeLONGINT_: + return FFEINFO_kindtypeINTEGER4; + + case FFECOM_rttypeLOGICAL_: + return FFEINFO_kindtypeLOGICAL1; + + case FFECOM_rttypeREAL_F2C_: + case FFECOM_rttypeREAL_GNU_: + return FFEINFO_kindtypeREAL1; + + case FFECOM_rttypeCOMPLEX_F2C_: + case FFECOM_rttypeCOMPLEX_GNU_: + return FFEINFO_kindtypeREAL1; + + case FFECOM_rttypeDOUBLE_: + return FFEINFO_kindtypeREAL2; + + case FFECOM_rttypeDBLCMPLX_F2C_: + case FFECOM_rttypeDBLCMPLX_GNU_: + return FFEINFO_kindtypeREAL2; + + case FFECOM_rttypeCHARACTER_: + return FFEINFO_kindtypeCHARACTER1; + + default: + return FFEINFO_kindtypeANY; + } +} + +void +ffecom_init_0 () +{ + tree endlink; + int i; + int j; + tree t; + tree field; + ffetype type; + ffetype base_type; + + /* This block of code comes from the now-obsolete cktyps.c. It checks + whether the compiler environment is buggy in known ways, some of which + would, if not explicitly checked here, result in subtle bugs in g77. */ + + if (ffe_is_do_internal_checks ()) + { + static char names[][12] + = + {"bar", "bletch", "foo", "foobar"}; + char *name; + unsigned long ul; + double fl; + + name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]), + (int (*)()) strcmp); + if (name != (char *) &names[2]) + { + assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h" + == NULL); + abort (); + } + + ul = strtoul ("123456789", NULL, 10); + if (ul != 123456789L) + { + assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\ + in proj.h" == NULL); + abort (); + } + + fl = atof ("56.789"); + if ((fl < 56.788) || (fl > 56.79)) + { + assert ("atof not type double, fix your #include " + == NULL); + abort (); + } + } + +#if FFECOM_GCC_INCLUDE + ffecom_initialize_char_syntax_ (); +#endif + + ffecom_outer_function_decl_ = NULL_TREE; + current_function_decl = NULL_TREE; + named_labels = NULL_TREE; + current_binding_level = NULL_BINDING_LEVEL; + free_binding_level = NULL_BINDING_LEVEL; + pushlevel (0); /* make the binding_level structure for + global names */ + global_binding_level = current_binding_level; + + /* Define `int' and `char' first so that dbx will output them first. */ + + integer_type_node = make_signed_type (INT_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("int"), + integer_type_node)); + + char_type_node = make_unsigned_type (CHAR_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("char"), + char_type_node)); + + long_integer_type_node = make_signed_type (LONG_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"), + long_integer_type_node)); + + unsigned_type_node = make_unsigned_type (INT_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"), + unsigned_type_node)); + + long_unsigned_type_node = make_unsigned_type (LONG_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"), + long_unsigned_type_node)); + + long_long_integer_type_node = make_signed_type (LONG_LONG_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"), + long_long_integer_type_node)); + + long_long_unsigned_type_node = make_unsigned_type (LONG_LONG_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"), + long_long_unsigned_type_node)); + + sizetype + = TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))); + + TREE_TYPE (TYPE_SIZE (integer_type_node)) = sizetype; + TREE_TYPE (TYPE_SIZE (char_type_node)) = sizetype; + TREE_TYPE (TYPE_SIZE (unsigned_type_node)) = sizetype; + TREE_TYPE (TYPE_SIZE (long_unsigned_type_node)) = sizetype; + TREE_TYPE (TYPE_SIZE (long_integer_type_node)) = sizetype; + TREE_TYPE (TYPE_SIZE (long_long_integer_type_node)) = sizetype; + TREE_TYPE (TYPE_SIZE (long_long_unsigned_type_node)) = sizetype; + + error_mark_node = make_node (ERROR_MARK); + TREE_TYPE (error_mark_node) = error_mark_node; + + short_integer_type_node = make_signed_type (SHORT_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"), + short_integer_type_node)); + + short_unsigned_type_node = make_unsigned_type (SHORT_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"), + short_unsigned_type_node)); + + /* Define both `signed char' and `unsigned char'. */ + signed_char_type_node = make_signed_type (CHAR_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"), + signed_char_type_node)); + + unsigned_char_type_node = make_unsigned_type (CHAR_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"), + unsigned_char_type_node)); + + float_type_node = make_node (REAL_TYPE); + TYPE_PRECISION (float_type_node) = FLOAT_TYPE_SIZE; + layout_type (float_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("float"), + float_type_node)); + + double_type_node = make_node (REAL_TYPE); + TYPE_PRECISION (double_type_node) = DOUBLE_TYPE_SIZE; + layout_type (double_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("double"), + double_type_node)); + + long_double_type_node = make_node (REAL_TYPE); + TYPE_PRECISION (long_double_type_node) = LONG_DOUBLE_TYPE_SIZE; + layout_type (long_double_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"), + long_double_type_node)); + + complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"), + complex_integer_type_node)); + + complex_float_type_node = ffecom_make_complex_type_ (float_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"), + complex_float_type_node)); + + complex_double_type_node = ffecom_make_complex_type_ (double_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"), + complex_double_type_node)); + + complex_long_double_type_node = ffecom_make_complex_type_ (long_double_type_node); + pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"), + complex_long_double_type_node)); + + integer_zero_node = build_int_2 (0, 0); + TREE_TYPE (integer_zero_node) = integer_type_node; + integer_one_node = build_int_2 (1, 0); + TREE_TYPE (integer_one_node) = integer_type_node; + + size_zero_node = build_int_2 (0, 0); + TREE_TYPE (size_zero_node) = sizetype; + size_one_node = build_int_2 (1, 0); + TREE_TYPE (size_one_node) = sizetype; + + void_type_node = make_node (VOID_TYPE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("void"), + void_type_node)); + layout_type (void_type_node); /* Uses integer_zero_node */ + /* We are not going to have real types in C with less than byte alignment, + so we might as well not have any types that claim to have it. */ + TYPE_ALIGN (void_type_node) = BITS_PER_UNIT; + + null_pointer_node = build_int_2 (0, 0); + TREE_TYPE (null_pointer_node) = build_pointer_type (void_type_node); + layout_type (TREE_TYPE (null_pointer_node)); + + string_type_node = build_pointer_type (char_type_node); + + ffecom_tree_fun_type_void + = build_function_type (void_type_node, NULL_TREE); + + ffecom_tree_ptr_to_fun_type_void + = build_pointer_type (ffecom_tree_fun_type_void); + + endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE); + + float_ftype_float + = build_function_type (float_type_node, + tree_cons (NULL_TREE, float_type_node, endlink)); + + double_ftype_double + = build_function_type (double_type_node, + tree_cons (NULL_TREE, double_type_node, endlink)); + + ldouble_ftype_ldouble + = build_function_type (long_double_type_node, + tree_cons (NULL_TREE, long_double_type_node, + endlink)); + + for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) + for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) + { + ffecom_tree_type[i][j] = NULL_TREE; + ffecom_tree_fun_type[i][j] = NULL_TREE; + ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE; + ffecom_f2c_typecode_[i][j] = -1; + } + + /* Set up standard g77 types. Note that INTEGER and LOGICAL are set + to size FLOAT_TYPE_SIZE because they have to be the same size as + REAL, which also is FLOAT_TYPE_SIZE, according to the standard. + Compiler options and other such stuff that change the ways these + types are set should not affect this particular setup. */ + + ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1] + = t = make_signed_type (FLOAT_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"), + t)); + type = ffetype_new (); + base_type = type; + ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 1, type); + assert (ffetype_size (type) == sizeof (ffetargetInteger1)); + + ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1] + = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */ + pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"), + t)); + + ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2] + = t = make_signed_type (CHAR_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 3, type); + assert (ffetype_size (type) == sizeof (ffetargetInteger2)); + + ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2] + = t = make_unsigned_type (CHAR_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"), + t)); + + ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3] + = t = make_signed_type (CHAR_TYPE_SIZE * 2); + pushdecl (build_decl (TYPE_DECL, get_identifier ("word"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 6, type); + assert (ffetype_size (type) == sizeof (ffetargetInteger3)); + + ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3] + = t = make_unsigned_type (CHAR_TYPE_SIZE * 2); + pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"), + t)); + + ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4] + = t = make_signed_type (FLOAT_TYPE_SIZE * 2); + pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 2, type); + assert (ffetype_size (type) == sizeof (ffetargetInteger4)); + + ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4] + = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2); + pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"), + t)); + +#if 0 + if (ffe_is_do_internal_checks () + && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE + && LONG_TYPE_SIZE != CHAR_TYPE_SIZE + && LONG_TYPE_SIZE != SHORT_TYPE_SIZE + && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE) + { + fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n", + LONG_TYPE_SIZE); + } +#endif + + ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1] + = t = make_signed_type (FLOAT_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"), + t)); + type = ffetype_new (); + base_type = type; + ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 1, type); + assert (ffetype_size (type) == sizeof (ffetargetLogical1)); + + ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2] + = t = make_signed_type (CHAR_TYPE_SIZE); + pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 3, type); + assert (ffetype_size (type) == sizeof (ffetargetLogical2)); + + ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3] + = t = make_signed_type (CHAR_TYPE_SIZE * 2); + pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 6, type); + assert (ffetype_size (type) == sizeof (ffetargetLogical3)); + + ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4] + = t = make_signed_type (FLOAT_TYPE_SIZE * 2); + pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 2, type); + assert (ffetype_size (type) == sizeof (ffetargetLogical4)); + + ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1] + = t = make_node (REAL_TYPE); + TYPE_PRECISION (t) = FLOAT_TYPE_SIZE; + pushdecl (build_decl (TYPE_DECL, get_identifier ("real"), + t)); + layout_type (t); + type = ffetype_new (); + base_type = type; + ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 1, type); + ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1] + = FFETARGET_f2cTYREAL; + assert (ffetype_size (type) == sizeof (ffetargetReal1)); + + ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE] + = t = make_node (REAL_TYPE); + TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2; /* Always twice REAL. */ + pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"), + t)); + layout_type (t); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 2, type); + ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2] + = FFETARGET_f2cTYDREAL; + assert (ffetype_size (type) == sizeof (ffetargetReal2)); + + ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1] + = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]); + pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"), + t)); + type = ffetype_new (); + base_type = type; + ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 1, type); + ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1] + = FFETARGET_f2cTYCOMPLEX; + assert (ffetype_size (type) == sizeof (ffetargetComplex1)); + + ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE] + = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]); + pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"), + t)); + type = ffetype_new (); + ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_star (base_type, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE, + type); + ffetype_set_kind (base_type, 2, + type); + ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2] + = FFETARGET_f2cTYDCOMPLEX; + assert (ffetype_size (type) == sizeof (ffetargetComplex2)); + + /* Make function and ptr-to-function types for non-CHARACTER types. */ + + for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) + for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) + { + if ((t = ffecom_tree_type[i][j]) != NULL_TREE) + { + if (i == FFEINFO_basictypeINTEGER) + { + /* Figure out the smallest INTEGER type that can hold + a pointer on this machine. */ + if (GET_MODE_SIZE (TYPE_MODE (t)) + >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node)))) + { + if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE) + || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_])) + > GET_MODE_SIZE (TYPE_MODE (t)))) + ffecom_pointer_kind_ = j; + } + } + else if (i == FFEINFO_basictypeCOMPLEX) + t = void_type_node; + /* For f2c compatibility, REAL functions are really + implemented as DOUBLE PRECISION. */ + else if ((i == FFEINFO_basictypeREAL) + && (j == FFEINFO_kindtypeREAL1)) + t = ffecom_tree_type + [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]; + + t = ffecom_tree_fun_type[i][j] = build_function_type (t, + NULL_TREE); + ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t); + } + } + + /* Set up pointer types. */ + + if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE) + fatal ("no INTEGER type can hold a pointer on this configuration"); + else if (0 && ffe_is_do_internal_checks ()) + fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_); + type = ffetype_new (); + ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT), + 7, type); + + if (ffe_is_ugly_assign ()) + ffecom_label_kind_ = ffecom_pointer_kind_; /* Require ASSIGN etc to this. */ + else + ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT; + if (0 && ffe_is_do_internal_checks ()) + fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_); + + ffecom_integer_type_node + = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]; + ffecom_integer_zero_node = convert (ffecom_integer_type_node, + integer_zero_node); + ffecom_integer_one_node = convert (ffecom_integer_type_node, + integer_one_node); + + /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional. + Turns out that by TYLONG, runtime/libI77/lio.h really means + "whatever size an ftnint is". For consistency and sanity, + com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen + all are INTEGER, which we also make out of whatever back-end + integer type is FLOAT_TYPE_SIZE bits wide. This change, from + LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to + accommodate machines like the Alpha. Note that this suggests + f2c and libf2c are missing a distinction perhaps needed on + some machines between "int" and "long int". -- burley 0.5.5 950215 */ + + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE, + FFETARGET_f2cTYLONG); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE, + FFETARGET_f2cTYSHORT); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE, + FFETARGET_f2cTYINT1); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE, + FFETARGET_f2cTYQUAD); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE, + FFETARGET_f2cTYLOGICAL); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE, + FFETARGET_f2cTYLOGICAL2); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE, + FFETARGET_f2cTYLOGICAL1); + ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE, + FFETARGET_f2cTYQUAD /* ~~~ */); + + /* CHARACTER stuff is all special-cased, so it is not handled in the above + loop. CHARACTER items are built as arrays of unsigned char. */ + + ffecom_tree_type[FFEINFO_basictypeCHARACTER] + [FFEINFO_kindtypeCHARACTER1] = t = char_type_node; + type = ffetype_new (); + base_type = type; + ffeinfo_set_type (FFEINFO_basictypeCHARACTER, + FFEINFO_kindtypeCHARACTER1, + type); + ffetype_set_ams (type, + TYPE_ALIGN (t) / BITS_PER_UNIT, 0, + TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT); + ffetype_set_kind (base_type, 1, type); + assert (ffetype_size (type) + == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0])); + + ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER] + [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void; + ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER] + [FFEINFO_kindtypeCHARACTER1] + = ffecom_tree_ptr_to_fun_type_void; + ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1] + = FFETARGET_f2cTYCHAR; + + ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY] + = 0; + + /* Make multi-return-value type and fields. */ + + ffecom_multi_type_node_ = make_node (UNION_TYPE); + + field = NULL_TREE; + + for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) + for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) + { + char name[30]; + + if (ffecom_tree_type[i][j] == NULL_TREE) + continue; /* Not supported. */ + sprintf (&name[0], "bt_%s_kt_%s", + ffeinfo_basictype_string ((ffeinfoBasictype) i), + ffeinfo_kindtype_string ((ffeinfoKindtype) j)); + ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL, + get_identifier (name), + ffecom_tree_type[i][j]); + DECL_CONTEXT (ffecom_multi_fields_[i][j]) + = ffecom_multi_type_node_; + DECL_FRAME_SIZE (ffecom_multi_fields_[i][j]) = 0; + TREE_CHAIN (ffecom_multi_fields_[i][j]) = field; + field = ffecom_multi_fields_[i][j]; + } + + TYPE_FIELDS (ffecom_multi_type_node_) = field; + layout_type (ffecom_multi_type_node_); + + /* Subroutines usually return integer because they might have alternate + returns. */ + + ffecom_tree_subr_type + = build_function_type (integer_type_node, NULL_TREE); + ffecom_tree_ptr_to_subr_type + = build_pointer_type (ffecom_tree_subr_type); + ffecom_tree_blockdata_type + = build_function_type (void_type_node, NULL_TREE); + + builtin_function ("__builtin_sqrtf", float_ftype_float, + BUILT_IN_FSQRT, "sqrtf"); + builtin_function ("__builtin_fsqrt", double_ftype_double, + BUILT_IN_FSQRT, "sqrt"); + builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble, + BUILT_IN_FSQRT, "sqrtl"); + builtin_function ("__builtin_sinf", float_ftype_float, + BUILT_IN_SIN, "sinf"); + builtin_function ("__builtin_sin", double_ftype_double, + BUILT_IN_SIN, "sin"); + builtin_function ("__builtin_sinl", ldouble_ftype_ldouble, + BUILT_IN_SIN, "sinl"); + builtin_function ("__builtin_cosf", float_ftype_float, + BUILT_IN_COS, "cosf"); + builtin_function ("__builtin_cos", double_ftype_double, + BUILT_IN_COS, "cos"); + builtin_function ("__builtin_cosl", ldouble_ftype_ldouble, + BUILT_IN_COS, "cosl"); + +#if BUILT_FOR_270 + pedantic_lvalues = FALSE; +#endif + + ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node, + FFECOM_f2cINTEGER, + "integer"); + ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node, + FFECOM_f2cADDRESS, + "address"); + ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node, + FFECOM_f2cREAL, + "real"); + ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node, + FFECOM_f2cDOUBLEREAL, + "doublereal"); + ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node, + FFECOM_f2cCOMPLEX, + "complex"); + ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node, + FFECOM_f2cDOUBLECOMPLEX, + "doublecomplex"); + ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node, + FFECOM_f2cLONGINT, + "longint"); + ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node, + FFECOM_f2cLOGICAL, + "logical"); + ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node, + FFECOM_f2cFLAG, + "flag"); + ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node, + FFECOM_f2cFTNLEN, + "ftnlen"); + ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node, + FFECOM_f2cFTNINT, + "ftnint"); + + ffecom_f2c_ftnlen_zero_node + = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node); + + ffecom_f2c_ftnlen_one_node + = convert (ffecom_f2c_ftnlen_type_node, integer_one_node); + + ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0); + TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node; + + ffecom_f2c_ptr_to_ftnlen_type_node + = build_pointer_type (ffecom_f2c_ftnlen_type_node); + + ffecom_f2c_ptr_to_ftnint_type_node + = build_pointer_type (ffecom_f2c_ftnint_type_node); + + ffecom_f2c_ptr_to_integer_type_node + = build_pointer_type (ffecom_f2c_integer_type_node); + + ffecom_f2c_ptr_to_real_type_node + = build_pointer_type (ffecom_f2c_real_type_node); + + ffecom_float_zero_ = build_real (float_type_node, dconst0); + ffecom_double_zero_ = build_real (double_type_node, dconst0); + { + REAL_VALUE_TYPE point_5; + +#ifdef REAL_ARITHMETIC + REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2); +#else + point_5 = .5; +#endif + ffecom_float_half_ = build_real (float_type_node, point_5); + ffecom_double_half_ = build_real (double_type_node, point_5); + } + + /* Do "extern int xargc;". */ + + ffecom_tree_xargc_ = build_decl (VAR_DECL, + get_identifier ("xargc"), + integer_type_node); + DECL_EXTERNAL (ffecom_tree_xargc_) = 1; + TREE_STATIC (ffecom_tree_xargc_) = 1; + TREE_PUBLIC (ffecom_tree_xargc_) = 1; + ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE); + finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE); + +#if 0 /* This is being fixed, and seems to be working now. */ + if ((FLOAT_TYPE_SIZE != 32) + || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32)) + { + warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,", + (int) FLOAT_TYPE_SIZE); + warning ("and pointers are %d bits wide, but g77 doesn't yet work", + (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node)))); + warning ("properly unless they all are 32 bits wide."); + warning ("Please keep this in mind before you report bugs. g77 should"); + warning ("support non-32-bit machines better as of version 0.6."); + } +#endif + +#if 0 /* Code in ste.c that would crash has been commented out. */ + if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node) + < TYPE_PRECISION (string_type_node)) + /* I/O will probably crash. */ + warning ("configuration: char * holds %d bits, but ftnlen only %d", + TYPE_PRECISION (string_type_node), + TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)); +#endif + +#if 0 /* ASSIGN-related stuff has been changed to accommodate this. */ + if (TYPE_PRECISION (ffecom_integer_type_node) + < TYPE_PRECISION (string_type_node)) + /* ASSIGN 10 TO I will crash. */ + warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\ + ASSIGN statement might fail", + TYPE_PRECISION (string_type_node), + TYPE_PRECISION (ffecom_integer_type_node)); +#endif +} + +#endif +/* ffecom_init_2 -- Initialize + + ffecom_init_2(); */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_init_2 () +{ + assert (ffecom_outer_function_decl_ == NULL_TREE); + assert (current_function_decl == NULL_TREE); + assert (ffecom_which_entrypoint_decl_ == NULL_TREE); + + ffecom_master_arglist_ = NULL; + ++ffecom_num_fns_; + ffecom_latest_temp_ = NULL; + ffecom_primary_entry_ = NULL; + ffecom_is_altreturning_ = FALSE; + ffecom_func_result_ = NULL_TREE; + ffecom_multi_retval_ = NULL_TREE; +} + +#endif +/* ffecom_list_expr -- Transform list of exprs into gcc tree + + tree t; + ffebld expr; // FFE opITEM list. + tree = ffecom_list_expr(expr); + + List of actual args is transformed into corresponding gcc backend list. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_list_expr (ffebld expr) +{ + tree list; + tree *plist = &list; + tree trail = NULL_TREE; /* Append char length args here. */ + tree *ptrail = &trail; + tree length; + + while (expr != NULL) + { + *plist + = build_tree_list (NULL_TREE, ffecom_arg_expr (ffebld_head (expr), + &length)); + plist = &TREE_CHAIN (*plist); + expr = ffebld_trail (expr); + if (length != NULL_TREE) + { + *ptrail = build_tree_list (NULL_TREE, length); + ptrail = &TREE_CHAIN (*ptrail); + } + } + + *plist = trail; + + return list; +} + +#endif +/* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree + + tree t; + ffebld expr; // FFE opITEM list. + tree = ffecom_list_ptr_to_expr(expr); + + 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) +{ + tree list; + tree *plist = &list; + tree trail = NULL_TREE; /* Append char length args here. */ + tree *ptrail = &trail; + tree length; + + while (expr != NULL) + { + *plist + = build_tree_list (NULL_TREE, + ffecom_arg_ptr_to_expr (ffebld_head (expr), + &length)); + plist = &TREE_CHAIN (*plist); + expr = ffebld_trail (expr); + if (length != NULL_TREE) + { + *ptrail = build_tree_list (NULL_TREE, length); + ptrail = &TREE_CHAIN (*ptrail); + } + } + + *plist = trail; + + return list; +} + +#endif +/* Obtain gcc's LABEL_DECL tree for label. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_lookup_label (ffelab label) +{ + tree glabel; + + if (ffelab_hook (label) == NULL_TREE) + { + char labelname[16]; + + switch (ffelab_type (label)) + { + case FFELAB_typeLOOPEND: + case FFELAB_typeNOTLOOP: + case FFELAB_typeENDIF: + sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label)); + glabel = build_decl (LABEL_DECL, get_identifier (labelname), + void_type_node); + DECL_CONTEXT (glabel) = current_function_decl; + DECL_MODE (glabel) = VOIDmode; + break; + + case FFELAB_typeFORMAT: + push_obstacks_nochange (); + end_temporary_allocation (); + + glabel = build_decl (VAR_DECL, + ffecom_get_invented_identifier + ("__g77_format_%d", NULL, + (int) ffelab_value (label)), + build_type_variant (build_array_type + (char_type_node, + NULL_TREE), + 1, 0)); + TREE_CONSTANT (glabel) = 1; + TREE_STATIC (glabel) = 1; + DECL_CONTEXT (glabel) = 0; + DECL_INITIAL (glabel) = NULL; + make_decl_rtl (glabel, NULL, 0); + expand_decl (glabel); + + resume_temporary_allocation (); + pop_obstacks (); + + break; + + case FFELAB_typeANY: + glabel = error_mark_node; + break; + + default: + assert ("bad label type" == NULL); + glabel = NULL; + break; + } + ffelab_set_hook (label, glabel); + } + else + { + glabel = ffelab_hook (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) +{ + if (lhs == error_mark_node || rhs == error_mark_node) + return error_mark_node; + + if (newtype == NULL_TREE) + newtype = TREE_TYPE (lhs); + + if (TREE_SIDE_EFFECTS (lhs)) + lhs = stabilize_reference (lhs); + + return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs); +} + +#endif + +/* Register source file name. */ + +void +ffecom_file (char *name) +{ +#if FFECOM_GCC_INCLUDE + ffecom_file_ (name); +#endif +} + +/* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed + + ffestorag st; + ffecom_notify_init_storage(st); + + Gets called when all possible units in an aggregate storage area (a LOCAL + with equivalences or a COMMON) have been initialized. The initialization + info either is in ffestorag_init or, if that is NULL, + ffestorag_accretion: + + ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur + even for an array if the array is one element in length! + + ffestorag_accretion will contain an opACCTER. It is much like an + opARRTER except it has an ffebit object in it instead of just a size. + The back end can use the info in the ffebit object, if it wants, to + reduce the amount of actual initialization, but in any case it should + kill the ffebit object when done. Also, set accretion to NULL but + init to a non-NULL value. + + After performing initialization, DO NOT set init to NULL, because that'll + tell the front end it is ok for more initialization to happen. Instead, + set init to an opANY expression or some such thing that you can use to + tell that you've already initialized the object. + + 27-Oct-91 JCB 1.1 + Support two-pass FFE. */ + +void +ffecom_notify_init_storage (ffestorag st) +{ + ffebld init; /* The initialization expression. */ +#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC + ffetargetOffset size; /* The size of the entity. */ +#endif + + if (ffestorag_init (st) == NULL) + { + init = ffestorag_accretion (st); + 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); + 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); +#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 + + ffesymbol s; + ffecom_notify_init_symbol(s); + + Gets called when all possible units in a symbol (not placed in COMMON + or involved in EQUIVALENCE, unless it as yet has no ffestorag object) + have been initialized. The initialization info either is in + ffesymbol_init or, if that is NULL, ffesymbol_accretion: + + ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur + even for an array if the array is one element in length! + + ffesymbol_accretion will contain an opACCTER. It is much like an + opARRTER except it has an ffebit object in it instead of just a size. + The back end can use the info in the ffebit object, if it wants, to + reduce the amount of actual initialization, but in any case it should + kill the ffebit object when done. Also, set accretion to NULL but + init to a non-NULL value. + + After performing initialization, DO NOT set init to NULL, because that'll + tell the front end it is ok for more initialization to happen. Instead, + set init to an opANY expression or some such thing that you can use to + tell that you've already initialized the object. + + 27-Oct-91 JCB 1.1 + Support two-pass FFE. */ + +void +ffecom_notify_init_symbol (ffesymbol s) +{ + ffebld init; /* The initialization expression. */ +#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC + ffetargetOffset size; /* The size of the entity. */ +#endif + + if (ffesymbol_storage (s) == NULL) + return; /* Do nothing until COMMON/EQUIVALENCE + possibilities checked. */ + + if ((ffesymbol_init (s) == NULL) + && ((init = ffesymbol_accretion (s)) != NULL)) + { + 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); + 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); +#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 + + ffesymbol s; + ffecom_notify_primary_entry(s); + + Gets called when implicit or explicit PROGRAM statement seen or when + FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary + global symbol that serves as the entry point. */ + +void +ffecom_notify_primary_entry (ffesymbol s) +{ + ffecom_primary_entry_ = s; + ffecom_primary_entry_kind_ = ffesymbol_kind (s); + + if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION) + || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)) + ffecom_primary_entry_is_proc_ = TRUE; + else + ffecom_primary_entry_is_proc_ = FALSE; + + if (!ffe_is_silent ()) + { + if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM) + fprintf (stderr, "%s:\n", ffesymbol_text (s)); + else + fprintf (stderr, " %s:\n", ffesymbol_text (s)); + } + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE) + { + ffebld list; + ffebld arg; + + for (list = ffesymbol_dummyargs (s); + list != NULL; + list = ffebld_trail (list)) + { + arg = ffebld_head (list); + if (ffebld_op (arg) == FFEBLD_opSTAR) + { + ffecom_is_altreturning_ = TRUE; + break; + } + } + } +#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 +} + +/* Clean up after making automatically popped call-arg temps. + + Call this in pairs with push_calltemps around calls to + ffecom_arg_ptr_to_expr if the latter might use temporaries. + Any temporaries made within the outermost sequence of + push_calltemps and pop_calltemps, that are marked as "auto-pop" + meaning they won't be explicitly popped (freed), are popped + at this point so they can be reused later. + + NOTE: when called by ffecom_gen_sfuncdef_, ffecom_pending_calls_ + should come in == 1, and all of the in-use auto-pop temps + should have DECL_CONTEXT (temp->t) == current_function_decl. + Moreover, these temps should _never_ be re-used in future + calls to ffecom_push_tempvar -- since current_function_decl will + never be the same again. + + SO, it could be a minor win in terms of compile time to just + strip these temps off the list. That is, if the above assumptions + are correct, just remove from the list of temps any temp + that is both in-use and has DECL_CONTEXT (temp->t) + == current_function_decl, when called from ffecom_gen_sfuncdef_. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_pop_calltemps () +{ + ffecomTemp_ temp; + + assert (ffecom_pending_calls_ > 0); + + if (--ffecom_pending_calls_ == 0) + for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next) + if (temp->auto_pop) + temp->in_use = FALSE; +} + +#endif +/* Mark latest temp with given tree as no longer in use. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_pop_tempvar (tree t) +{ + ffecomTemp_ temp; + + for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next) + if (temp->in_use && (temp->t == t)) + { + assert (!temp->auto_pop); + temp->in_use = FALSE; + return; + } + else + assert (temp->t != t); + + assert ("couldn't ffecom_pop_tempvar!" != NULL); +} + +#endif +/* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front + + tree t; + ffebld expr; // FFE expression. + tree = ffecom_ptr_to_expr(expr); + + Like ffecom_expr, but sticks address-of in front of most things. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_ptr_to_expr (ffebld expr) +{ + tree item; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffesymbol s; + + assert (expr != NULL); + + switch (ffebld_op (expr)) + { + case FFEBLD_opSYMTER: + s = ffebld_symter (expr); + if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC) + { + ffecomGfrt ix; + + ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr)); + assert (ix != FFECOM_gfrt); + if ((item = ffecom_gfrt_[ix]) == NULL_TREE) + { + ffecom_make_gfrt_ (ix); + item = ffecom_gfrt_[ix]; + } + } + else + { + item = ffesymbol_hook (s).decl_tree; + if (item == NULL_TREE) + { + s = ffecom_sym_transform_ (s); + item = ffesymbol_hook (s).decl_tree; + } + } + assert (item != NULL); + if (item == error_mark_node) + return item; + if (!ffesymbol_hook (s).addr) + item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)), + item); + return item; + + case FFEBLD_opARRAYREF: + { + ffebld dims[FFECOM_dimensionsMAX]; + tree array; + int i; + + item = ffecom_ptr_to_expr (ffebld_left (expr)); + + if (item == error_mark_node) + return item; + + if ((ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING) + && !mark_addressable (item)) + return error_mark_node; /* Make sure non-const ref is to + non-reg. */ + + /* Build up ARRAY_REFs in reverse order (since we're column major + here in Fortran land). */ + + for (i = 0, expr = ffebld_right (expr); + expr != NULL; + expr = ffebld_trail (expr)) + dims[i++] = ffebld_head (expr); + + for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))); + i >= 0; + --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array))) + { + item + = ffecom_2 (PLUS_EXPR, + build_pointer_type (TREE_TYPE (array)), + item, + size_binop (MULT_EXPR, + size_in_bytes (TREE_TYPE (array)), + size_binop (MINUS_EXPR, + ffecom_expr (dims[i]), + TYPE_MIN_VALUE (TYPE_DOMAIN (array))))); + } + } + return item; + + case FFEBLD_opCONTER: + + bt = ffeinfo_basictype (ffebld_info (expr)); + kt = ffeinfo_kindtype (ffebld_info (expr)); + + item = ffecom_constantunion (&ffebld_constant_union + (ffebld_conter (expr)), bt, kt, + ffecom_tree_type[bt][kt]); + if (item == error_mark_node) + return error_mark_node; + item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)), + item); + return item; + + case FFEBLD_opANY: + return error_mark_node; + + default: + assert (ffecom_pending_calls_ > 0); + + bt = ffeinfo_basictype (ffebld_info (expr)); + kt = ffeinfo_kindtype (ffebld_info (expr)); + + item = ffecom_expr (expr); + if (item == error_mark_node) + return error_mark_node; + + /* The back end currently optimizes a bit too zealously for us, in that + we fail JCB001 if the following block of code is omitted. It checks + to see if the transformed expression is a symbol or array reference, + and encloses it in a SAVE_EXPR if that is the case. */ + + STRIP_NOPS (item); + if ((TREE_CODE (item) == VAR_DECL) + || (TREE_CODE (item) == PARM_DECL) + || (TREE_CODE (item) == RESULT_DECL) + || (TREE_CODE (item) == INDIRECT_REF) + || (TREE_CODE (item) == ARRAY_REF) + || (TREE_CODE (item) == COMPONENT_REF) +#ifdef OFFSET_REF + || (TREE_CODE (item) == OFFSET_REF) +#endif + || (TREE_CODE (item) == BUFFER_REF) + || (TREE_CODE (item) == REALPART_EXPR) + || (TREE_CODE (item) == IMAGPART_EXPR)) + { + item = ffecom_save_tree (item); + } + + item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)), + item); + return item; + } + + assert ("fall-through error" == NULL); + return error_mark_node; +} + +#endif +/* Prepare to make call-arg temps. + + Call this in pairs with pop_calltemps around calls to + ffecom_arg_ptr_to_expr if the latter might use temporaries. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffecom_push_calltemps () +{ + ffecom_pending_calls_++; +} + +#endif +/* Obtain a temp var with given data type. + + Returns a VAR_DECL tree of a currently (that is, at the current + statement being compiled) not in use and having the given data type, + making a new one if necessary. size is FFETARGET_charactersizeNONE + for a non-CHARACTER type or >= 0 for a CHARACTER type. elements is + -1 for a scalar or > 0 for an array of type. auto_pop is TRUE if + ffecom_pop_tempvar won't be called, meaning temp will be freed + when #pending calls goes to zero. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_push_tempvar (tree type, ffetargetCharacterSize size, int elements, + bool auto_pop) +{ + ffecomTemp_ temp; + int yes; + tree t; + static int mynumber; + + assert (!auto_pop || (ffecom_pending_calls_ > 0)); + + if (type == error_mark_node) + return error_mark_node; + + for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next) + { + if (temp->in_use + || (temp->type != type) + || (temp->size != size) + || (temp->elements != elements) + || (DECL_CONTEXT (temp->t) != current_function_decl)) + continue; + + temp->in_use = TRUE; + temp->auto_pop = auto_pop; + return temp->t; + } + + /* Create a new temp. */ + + yes = suspend_momentary (); + + if (size != FFETARGET_charactersizeNONE) + type = build_array_type (type, + build_range_type (ffecom_f2c_ftnlen_type_node, + ffecom_f2c_ftnlen_one_node, + build_int_2 (size, 0))); + if (elements != -1) + type = build_array_type (type, + build_range_type (integer_type_node, + integer_zero_node, + build_int_2 (elements - 1, + 0))); + t = build_decl (VAR_DECL, + ffecom_get_invented_identifier ("__g77_expr_%d", NULL, + mynumber++), + type); + { /* ~~~~ kludge alert here!!! else temp gets reused outside + a compound-statement sequence.... */ + extern tree sequence_rtl_expr; + tree back_end_bug = sequence_rtl_expr; + + sequence_rtl_expr = NULL_TREE; + + t = start_decl (t, FALSE); + finish_decl (t, NULL_TREE, FALSE); + + sequence_rtl_expr = back_end_bug; + } + + resume_momentary (yes); + + temp = malloc_new_kp (ffe_pool_program_unit (), "ffecomTemp_", + sizeof (*temp)); + + temp->next = ffecom_latest_temp_; + temp->type = type; + temp->t = t; + temp->size = size; + temp->elements = elements; + temp->in_use = TRUE; + temp->auto_pop = auto_pop; + + ffecom_latest_temp_ = temp; + + return t; +} + +#endif +/* ffecom_return_expr -- Returns return-value expr given alt return expr + + tree rtn; // NULL_TREE means use expand_null_return() + ffebld expr; // NULL if no alt return expr to RETURN stmt + rtn = ffecom_return_expr(expr); + + Based on the program unit type and other info (like return function + type, return master function type when alternate ENTRY points, + whether subroutine has any alternate RETURN points, etc), returns the + appropriate expression to be returned to the caller, or NULL_TREE + 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) +{ + tree rtn; + + switch (ffecom_primary_entry_kind_) + { + case FFEINFO_kindPROGRAM: + case FFEINFO_kindBLOCKDATA: + rtn = NULL_TREE; + break; + + case FFEINFO_kindSUBROUTINE: + if (!ffecom_is_altreturning_) + rtn = NULL_TREE; /* No alt returns, never an expr. */ + else if (expr == NULL) + rtn = integer_zero_node; + else + rtn = ffecom_expr (expr); + break; + + case FFEINFO_kindFUNCTION: + if ((ffecom_multi_retval_ != NULL_TREE) + || (ffesymbol_basictype (ffecom_primary_entry_) + == FFEINFO_basictypeCHARACTER) + || ((ffesymbol_basictype (ffecom_primary_entry_) + == FFEINFO_basictypeCOMPLEX) + && (ffecom_num_entrypoints_ == 0) + && ffesymbol_is_f2c (ffecom_primary_entry_))) + { /* Value is returned by direct assignment + into (implicit) dummy. */ + rtn = NULL_TREE; + break; + } + rtn = ffecom_func_result_; +#if 0 + /* Spurious error if RETURN happens before first reference! So elide + this code. In particular, for debugging registry, rtn should always + be non-null after all, but TREE_USED won't be set until we encounter + a reference in the code. Perfectly okay (but weird) code that, + e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in + this diagnostic for no reason. Have people use -O -Wuninitialized + and leave it to the back end to find obviously weird cases. */ + + /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid + situation; if the return value has never been referenced, it won't + have a tree under 2pass mode. */ + if ((rtn == NULL_TREE) + || !TREE_USED (rtn)) + { + ffebad_start (FFEBAD_RETURN_VALUE_UNSET); + ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_), + ffesymbol_where_column (ffecom_primary_entry_)); + ffebad_string (ffesymbol_text (ffesymbol_funcresult + (ffecom_primary_entry_))); + ffebad_finish (); + } +#endif + break; + + default: + assert ("bad unit kind" == NULL); + case FFEINFO_kindANY: + rtn = error_mark_node; + break; + } + + 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 + +/* Public entry point for front end to access start_decl. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_start_decl (tree decl, bool is_initialized) +{ + DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE; + return start_decl (decl, FALSE); +} + +#endif +/* ffecom_sym_commit -- Symbol's state being committed to reality + + ffesymbol s; + ffecom_sym_commit(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(); + + Does backend-specific stuff and also calls ffest_sym_end_transition + to do the necessary FFE stuff. + + Backtracking is never enabled when this fn is called, so don't worry + about it. */ + +ffesymbol +ffecom_sym_end_transition (ffesymbol s) +{ + ffestorag st; + + assert (!ffesymbol_retractable ()); + + s = ffest_sym_end_transition (s); + +#if FFECOM_targetCURRENT == FFECOM_targetGCC + if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA) + && (ffesymbol_where (s) == FFEINFO_whereGLOBAL)) + { + ffecom_list_blockdata_ + = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE, + FFEINTRIN_specNONE, + FFEINTRIN_impNONE), + ffecom_list_blockdata_); + } +#endif + + /* This is where we finally notice that a symbol has partial initialization + and finalize it. */ + + if (ffesymbol_accretion (s) != NULL) + { + assert (ffesymbol_init (s) == NULL); + ffecom_notify_init_symbol (s); + } + else if (((st = ffesymbol_storage (s)) != NULL) + && ((st = ffestorag_parent (st)) != NULL) + && (ffestorag_accretion (st) != NULL)) + { + assert (ffestorag_init (st) == NULL); + 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)) + { + ffecom_list_common_ + = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE, + FFEINTRIN_specNONE, + FFEINTRIN_impNONE), + ffecom_list_common_); + } +#endif + + return s; +} + +/* ffecom_sym_exec_transition -- Perform exec transition on all symbols + + ffecom_sym_exec_transition(); + + Does backend-specific stuff and also calls ffest_sym_exec_transition + to do the necessary FFE stuff. + + See the long-winded description in ffecom_sym_learned for info + on handling the situation where backtracking is inhibited. */ + +ffesymbol +ffecom_sym_exec_transition (ffesymbol s) +{ + s = ffest_sym_exec_transition (s); + + return s; +} + +/* ffecom_sym_learned -- Initial or more info gained on symbol after exec + + ffesymbol s; + s = ffecom_sym_learned(s); + + Called when a new symbol is seen after the exec transition or when more + info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when + it arrives here is that all its latest info is updated already, so its + state may be UNCERTAIN or UNDERSTOOD, it might already have the hook + field filled in if its gone through here or exec_transition first, and + so on. + + The backend probably wants to check ffesymbol_retractable() to see if + backtracking is in effect. If so, the FFE's changes to the symbol may + be retracted (undone) or committed (ratified), at which time the + appropriate ffecom_sym_retract or _commit function will be called + for that function. + + If the backend has its own backtracking mechanism, great, use it so that + committal is a simple operation. Though it doesn't make much difference, + I suppose: the reason for tentative symbol evolution in the FFE is to + enable error detection in weird incorrect statements early and to disable + incorrect error detection on a correct statement. The backend is not + likely to introduce any information that'll get involved in these + considerations, so it is probably just fine that the implementation + model for this fn and for _exec_transition is to not do anything + (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE + and instead wait until ffecom_sym_commit is called (which it never + will be as long as we're using ambiguity-detecting statement analysis in + the FFE, which we are initially to shake out the code, but don't depend + on this), otherwise go ahead and do whatever is needed. + + In essence, then, when this fn and _exec_transition get called while + backtracking is enabled, a general mechanism would be to flag which (or + both) of these were called (and in what order? neat question as to what + might happen that I'm too lame to think through right now) and then when + _commit is called reproduce the original calling sequence, if any, for + the two fns (at which point backtracking will, of course, be disabled). */ + +ffesymbol +ffecom_sym_learned (ffesymbol s) +{ + ffestorag_exec_layout (s); + + return s; +} + +/* ffecom_sym_retract -- Symbol's state being retracted from reality + + ffesymbol s; + ffecom_sym_retract(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) +{ + assert (!ffesymbol_retractable ()); + +#if 0 /* GCC doesn't commit any backtrackable sins, + so nothing needed here. */ + switch (ffesymbol_hook (s).state) + { + case 0: /* nothing happened yet. */ + break; + + case 1: /* exec transition happened. */ + break; + + case 2: /* learned happened. */ + break; + + case 3: /* learned then exec. */ + break; + + case 4: /* exec then learned. */ + break; + + default: + assert ("bad hook state" == NULL); + break; + } +#endif +} + +#endif +/* Create temporary gcc label. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +tree +ffecom_temp_label () +{ + tree glabel; + static int mynumber = 0; + + glabel = build_decl (LABEL_DECL, + ffecom_get_invented_identifier ("__g77_label_%d", + NULL, + mynumber++), + void_type_node); + DECL_CONTEXT (glabel) = current_function_decl; + DECL_MODE (glabel) = VOIDmode; + + 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 PARM_DECL for arg#1 of master fn containing alternate ENTRY points + + If the PARM_DECL already exists, return it, else create it. It's an + integer_type_node argument for the master function that implements a + subroutine or function with more than one entrypoint and is bound at + 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 () +{ + assert (ffecom_which_entrypoint_decl_ != NULL_TREE); + + return ffecom_which_entrypoint_decl_; +} + +#endif + +/* The following sections consists of private and public functions + that have the same names and perform roughly the same functions + as counterparts in the C front end. Changes in the C front end + might affect how things should be done here. Only functions + needed by the back end should be public here; the rest should + be private (static in the C sense). Functions needed by other + g77 front-end modules should be accessed by them via public + ffecom_* names, which should themselves call private versions + in this section so the private versions are easy to recognize + when upgrading to a new gcc and finding interesting changes + in the front end. + + 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_compstmt_ () +{ + emit_line_note (input_filename, lineno); + expand_end_bindings (getdecls (), 1, 1); + poplevel (1, 1, 0); + pop_momentary (); +} + +static void +bison_rule_pushlevel_ () +{ + emit_line_note (input_filename, lineno); + pushlevel (0); + clear_last_expr (); + push_momentary (); + expand_start_bindings (0); +} + +/* Return a definition for a builtin function named NAME and whose data type + is TYPE. TYPE should be a function type with argument types. + FUNCTION_CODE tells later passes how to compile calls to this function. + See tree.h for its possible values. + + If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME, + the name to be called if we can't opencode the function. */ + +static tree +builtin_function (char *name, tree type, + enum built_in_function function_code, char *library_name) +{ + tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type); + DECL_EXTERNAL (decl) = 1; + TREE_PUBLIC (decl) = 1; + if (library_name) + DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name); + make_decl_rtl (decl, NULL_PTR, 1); + pushdecl (decl); + if (function_code != NOT_BUILT_IN) + { + DECL_BUILT_IN (decl) = 1; + DECL_FUNCTION_CODE (decl) = function_code; + } + + return decl; +} + +/* Handle when a new declaration NEWDECL + has the same name as an old one OLDDECL + in the same binding contour. + Prints an error message if appropriate. + + If safely possible, alter OLDDECL to look like NEWDECL, and return 1. + Otherwise, return 0. */ + +static int +duplicate_decls (tree newdecl, tree olddecl) +{ + int types_match = 1; + int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL + && DECL_INITIAL (newdecl) != 0); + tree oldtype = TREE_TYPE (olddecl); + tree newtype = TREE_TYPE (newdecl); + + if (olddecl == newdecl) + return 1; + + if (TREE_CODE (newtype) == ERROR_MARK + || TREE_CODE (oldtype) == ERROR_MARK) + types_match = 0; + + /* New decl is completely inconsistent with the old one => + tell caller to replace the old one. + This is always an error except in the case of shadowing a builtin. */ + if (TREE_CODE (olddecl) != TREE_CODE (newdecl)) + return 0; + + /* For real parm decl following a forward decl, + return 1 so old decl will be reused. */ + if (types_match && TREE_CODE (newdecl) == PARM_DECL + && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl)) + return 1; + + /* The new declaration is the same kind of object as the old one. + The declarations may partially match. Print warnings if they don't + match enough. Ultimately, copy most of the information from the new + decl to the old one, and keep using the old one. */ + + if (TREE_CODE (olddecl) == FUNCTION_DECL + && DECL_BUILT_IN (olddecl)) + { + /* A function declaration for a built-in function. */ + if (!TREE_PUBLIC (newdecl)) + return 0; + else if (!types_match) + { + /* Accept the return type of the new declaration if same modes. */ + tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl)); + tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl)); + + /* Make sure we put the new type in the same obstack as the old ones. + If the old types are not both in the same obstack, use the + permanent one. */ + if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype)) + push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype)); + else + { + push_obstacks_nochange (); + end_temporary_allocation (); + } + + if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype)) + { + /* Function types may be shared, so we can't just modify + the return type of olddecl's function type. */ + tree newtype + = build_function_type (newreturntype, + TYPE_ARG_TYPES (TREE_TYPE (olddecl))); + + types_match = 1; + if (types_match) + TREE_TYPE (olddecl) = newtype; + } + + pop_obstacks (); + } + if (!types_match) + return 0; + } + else if (TREE_CODE (olddecl) == FUNCTION_DECL + && DECL_SOURCE_LINE (olddecl) == 0) + { + /* A function declaration for a predeclared function + that isn't actually built in. */ + if (!TREE_PUBLIC (newdecl)) + return 0; + else if (!types_match) + { + /* If the types don't match, preserve volatility indication. + Later on, we will discard everything else about the + default declaration. */ + TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl); + } + } + + /* Copy all the DECL_... slots specified in the new decl + except for any that we copy here from the old type. + + Past this point, we don't change OLDTYPE and NEWTYPE + even if we change the types of NEWDECL and OLDDECL. */ + + if (types_match) + { + /* Make sure we put the new type in the same obstack as the old ones. + If the old types are not both in the same obstack, use the permanent + one. */ + if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype)) + push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype)); + else + { + push_obstacks_nochange (); + end_temporary_allocation (); + } + + /* Merge the data types specified in the two decls. */ + if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl)) + TREE_TYPE (newdecl) + = TREE_TYPE (olddecl) + = TREE_TYPE (newdecl); + + /* Lay the type out, unless already done. */ + if (oldtype != TREE_TYPE (newdecl)) + { + if (TREE_TYPE (newdecl) != error_mark_node) + layout_type (TREE_TYPE (newdecl)); + if (TREE_CODE (newdecl) != FUNCTION_DECL + && TREE_CODE (newdecl) != TYPE_DECL + && TREE_CODE (newdecl) != CONST_DECL) + layout_decl (newdecl, 0); + } + else + { + /* Since the type is OLDDECL's, make OLDDECL's size go with. */ + DECL_SIZE (newdecl) = DECL_SIZE (olddecl); + if (TREE_CODE (olddecl) != FUNCTION_DECL) + if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl)) + DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl); + } + + /* Keep the old rtl since we can safely use it. */ + DECL_RTL (newdecl) = DECL_RTL (olddecl); + + /* Merge the type qualifiers. */ + if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl) + && !TREE_THIS_VOLATILE (newdecl)) + TREE_THIS_VOLATILE (olddecl) = 0; + if (TREE_READONLY (newdecl)) + TREE_READONLY (olddecl) = 1; + if (TREE_THIS_VOLATILE (newdecl)) + { + TREE_THIS_VOLATILE (olddecl) = 1; + if (TREE_CODE (newdecl) == VAR_DECL) + make_var_volatile (newdecl); + } + + /* Keep source location of definition rather than declaration. + Likewise, keep decl at outer scope. */ + if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0) + || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0)) + { + DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl); + DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl); + + if (DECL_CONTEXT (olddecl) == 0 + && TREE_CODE (newdecl) != FUNCTION_DECL) + DECL_CONTEXT (newdecl) = 0; + } + + /* Merge the unused-warning information. */ + if (DECL_IN_SYSTEM_HEADER (olddecl)) + DECL_IN_SYSTEM_HEADER (newdecl) = 1; + else if (DECL_IN_SYSTEM_HEADER (newdecl)) + DECL_IN_SYSTEM_HEADER (olddecl) = 1; + + /* Merge the initialization information. */ + if (DECL_INITIAL (newdecl) == 0) + DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl); + + /* Merge the section attribute. + We want to issue an error if the sections conflict but that must be + done later in decl_attributes since we are called before attributes + are assigned. */ + 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 + + pop_obstacks (); + } + /* If cannot merge, then use the new type and qualifiers, + and don't preserve the old rtl. */ + else + { + TREE_TYPE (olddecl) = TREE_TYPE (newdecl); + TREE_READONLY (olddecl) = TREE_READONLY (newdecl); + TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl); + TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl); + } + + /* Merge the storage class information. */ + /* For functions, static overrides non-static. */ + if (TREE_CODE (newdecl) == FUNCTION_DECL) + { + TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl); + /* This is since we don't automatically + copy the attributes of NEWDECL into OLDDECL. */ + TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl); + /* If this clears `static', clear it in the identifier too. */ + if (! TREE_PUBLIC (olddecl)) + TREE_PUBLIC (DECL_NAME (olddecl)) = 0; + } + if (DECL_EXTERNAL (newdecl)) + { + TREE_STATIC (newdecl) = TREE_STATIC (olddecl); + DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl); + /* An extern decl does not override previous storage class. */ + TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl); + } + else + { + TREE_STATIC (olddecl) = TREE_STATIC (newdecl); + TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl); + } + + /* If either decl says `inline', this fn is inline, + unless its definition was passed already. */ + if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0) + DECL_INLINE (olddecl) = 1; + DECL_INLINE (newdecl) = DECL_INLINE (olddecl); + + /* Get rid of any built-in function if new arg types don't match it + or if we have a function definition. */ + if (TREE_CODE (newdecl) == FUNCTION_DECL + && DECL_BUILT_IN (olddecl) + && (!types_match || new_is_definition)) + { + TREE_TYPE (olddecl) = TREE_TYPE (newdecl); + DECL_BUILT_IN (olddecl) = 0; + } + + /* If redeclaring a builtin function, and not a definition, + it stays built in. + Also preserve various other info from the definition. */ + if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition) + { + if (DECL_BUILT_IN (olddecl)) + { + DECL_BUILT_IN (newdecl) = 1; + DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl); + } + else + DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl); + + DECL_RESULT (newdecl) = DECL_RESULT (olddecl); + DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl); + DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl); + DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl); + } + + /* Copy most of the decl-specific fields of NEWDECL into OLDDECL. + But preserve olddecl's DECL_UID. */ + { + register unsigned olddecl_uid = DECL_UID (olddecl); + + bcopy ((char *) newdecl + sizeof (struct tree_common), + (char *) olddecl + sizeof (struct tree_common), + sizeof (struct tree_decl) - sizeof (struct tree_common)); + DECL_UID (olddecl) = olddecl_uid; + } + + return 1; +} + +/* Finish processing of a declaration; + install its initial value. + If the length of an array type is not known before, + it must be determined now, from the initial value, or it is an error. */ + +static void +finish_decl (tree decl, tree init, bool is_top_level) +{ + register tree type = TREE_TYPE (decl); + int was_incomplete = (DECL_SIZE (decl) == 0); + int temporary = allocation_temporary_p (); + bool at_top_level = (current_binding_level == global_binding_level); + bool top_level = is_top_level || at_top_level; + + /* Caller should pass TRUE for is_top_level only if we wouldn't be at top + level anyway. */ + assert (!is_top_level || !at_top_level); + + if (TREE_CODE (decl) == PARM_DECL) + assert (init == NULL_TREE); + /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it + overlaps DECL_ARG_TYPE. */ + else if (init == NULL_TREE) + assert (DECL_INITIAL (decl) == NULL_TREE); + else + assert (DECL_INITIAL (decl) == error_mark_node); + + if (init != NULL_TREE) + { + if (TREE_CODE (decl) != TYPE_DECL) + DECL_INITIAL (decl) = init; + else + { + /* typedef foo = bar; store the type of bar as the type of foo. */ + TREE_TYPE (decl) = TREE_TYPE (init); + DECL_INITIAL (decl) = init = 0; + } + } + + /* Pop back to the obstack that is current for this binding level. This is + because MAXINDEX, rtl, etc. to be made below must go in the permanent + obstack. But don't discard the temporary data yet. */ + pop_obstacks (); + + /* Deduce size of array from initialization, if not already known */ + + if (TREE_CODE (type) == ARRAY_TYPE + && TYPE_DOMAIN (type) == 0 + && TREE_CODE (decl) != TYPE_DECL) + { + assert (top_level); + assert (was_incomplete); + + layout_decl (decl, 0); + } + + if (TREE_CODE (decl) == VAR_DECL) + { + if (DECL_SIZE (decl) == NULL_TREE + && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE) + layout_decl (decl, 0); + + if (DECL_SIZE (decl) == NULL_TREE + && (TREE_STATIC (decl) + ? + /* A static variable with an incomplete type is an error if it is + initialized. Also if it is not file scope. Otherwise, let it + through, but if it is not `extern' then it may cause an error + message later. */ + (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0) + : + /* An automatic variable with an incomplete type is an error. */ + !DECL_EXTERNAL (decl))) + { + assert ("storage size not known" == NULL); + abort (); + } + + if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl)) + && (DECL_SIZE (decl) != 0) + && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST)) + { + assert ("storage size not constant" == NULL); + abort (); + } + } + + /* Output the assembler code and/or RTL code for variables and functions, + unless the type is an undefined structure or union. If not, it will get + done when the type is completed. */ + + if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL) + { + rest_of_decl_compilation (decl, NULL, + DECL_CONTEXT (decl) == 0, + 0); + + if (DECL_CONTEXT (decl) != 0) + { + /* Recompute the RTL of a local array now if it used to be an + incomplete type. */ + if (was_incomplete + && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl)) + { + /* If we used it already as memory, it must stay in memory. */ + TREE_ADDRESSABLE (decl) = TREE_USED (decl); + /* If it's still incomplete now, no init will save it. */ + if (DECL_SIZE (decl) == 0) + DECL_INITIAL (decl) = 0; + expand_decl (decl); + } + /* Compute and store the initial value. */ + if (TREE_CODE (decl) != FUNCTION_DECL) + expand_decl_init (decl); + } + } + else if (TREE_CODE (decl) == TYPE_DECL) + { + rest_of_decl_compilation (decl, NULL_PTR, + DECL_CONTEXT (decl) == 0, + 0); + } + + /* This test used to include TREE_PERMANENT, however, we have the same + problem with initializers at the function level. Such initializers get + saved until the end of the function on the momentary_obstack. */ + if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl)) + && temporary + /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with + DECL_ARG_TYPE. */ + && TREE_CODE (decl) != PARM_DECL) + { + /* We need to remember that this array HAD an initialization, but + discard the actual temporary nodes, since we can't have a permanent + node keep pointing to them. */ + /* We make an exception for inline functions, since it's normal for a + local extern redeclaration of an inline function to have a copy of + the top-level decl's DECL_INLINE. */ + if ((DECL_INITIAL (decl) != 0) + && (DECL_INITIAL (decl) != error_mark_node)) + { + /* If this is a const variable, then preserve the + initializer instead of discarding it so that we can optimize + references to it. */ + /* This test used to include TREE_STATIC, but this won't be set + for function level initializers. */ + if (TREE_READONLY (decl)) + { + preserve_initializer (); + /* Hack? Set the permanent bit for something that is + permanent, but not on the permenent obstack, so as to + convince output_constant_def to make its rtl on the + permanent obstack. */ + TREE_PERMANENT (DECL_INITIAL (decl)) = 1; + + /* The initializer and DECL must have the same (or equivalent + types), but if the initializer is a STRING_CST, its type + might not be on the right obstack, so copy the type + of DECL. */ + TREE_TYPE (DECL_INITIAL (decl)) = type; + } + else + DECL_INITIAL (decl) = error_mark_node; + } + } + + /* If requested, warn about definitions of large data objects. */ + + if (warn_larger_than + && (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL) + && !DECL_EXTERNAL (decl)) + { + register tree decl_size = DECL_SIZE (decl); + + if (decl_size && TREE_CODE (decl_size) == INTEGER_CST) + { + unsigned units = TREE_INT_CST_LOW (decl_size) / BITS_PER_UNIT; + + if (units > larger_than_size) + warning_with_decl (decl, "size of `%s' is %u bytes", units); + } + } + + /* If we have gone back from temporary to permanent allocation, actually + free the temporary space that we no longer need. */ + if (temporary && !allocation_temporary_p ()) + permanent_allocation (0); + + /* At the end of a declaration, throw away any variable type sizes of types + defined inside that declaration. There is no use computing them in the + following function definition. */ + if (current_binding_level == global_binding_level) + get_pending_sizes (); +} + +/* Finish up a function declaration and compile that function + all the way to assembler language output. The free the storage + for the function definition. + + This is called after parsing the body of the function definition. + + NESTED is nonzero if the function being finished is nested in another. */ + +static void +finish_function (int nested) +{ + register tree fndecl = current_function_decl; + + assert (fndecl != NULL_TREE); + if (nested) + assert (DECL_CONTEXT (fndecl) != NULL_TREE); + else + assert (DECL_CONTEXT (fndecl) == NULL_TREE); + +/* TREE_READONLY (fndecl) = 1; + This caused &foo to be of type ptr-to-const-function + which then got a warning when stored in a ptr-to-function variable. */ + + poplevel (1, 0, 1); + BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; + + /* Must mark the RESULT_DECL as being in this function. */ + + DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl; + + /* Obey `register' declarations if `setjmp' is called in this fn. */ + /* Generate rtl for function exit. */ + expand_function_end (input_filename, lineno, 0); + + /* So we can tell if jump_optimize sets it to 1. */ + can_reach_end = 0; + + /* Run the optimizers and output the assembler code for this function. */ + rest_of_compilation (fndecl); + + /* Free all the tree nodes making up this function. */ + /* Switch back to allocating nodes permanently until we start another + function. */ + if (!nested) + permanent_allocation (1); + + if (DECL_SAVED_INSNS (fndecl) == 0 && !nested) + { + /* Stop pointing to the local nodes about to be freed. */ + /* But DECL_INITIAL must remain nonzero so we know this was an actual + function definition. */ + /* For a nested function, this is done in pop_f_function_context. */ + /* If rest_of_compilation set this to 0, leave it 0. */ + if (DECL_INITIAL (fndecl) != 0) + DECL_INITIAL (fndecl) = error_mark_node; + DECL_ARGUMENTS (fndecl) = 0; + } + + if (!nested) + { + /* Let the error reporting routines know that we're outside a function. + For a nested function, this value is used in pop_c_function_context + and then reset via pop_function_context. */ + ffecom_outer_function_decl_ = current_function_decl = NULL; + } +} + +/* Plug-in replacement for identifying the name of a decl and, for a + function, what we call it in diagnostics. For now, "program unit" + should suffice, since it's a bit of a hassle to figure out which + of several kinds of things it is. Note that it could conceivably + be a statement function, which probably isn't really a program unit + per se, but if that comes up, it should be easy to check (being a + nested function and all). */ + +static char * +lang_printable_name (tree decl, char **kind) +{ + *kind = "program unit"; + return IDENTIFIER_POINTER (DECL_NAME (decl)); +} + +/* g77's function to print out name of current function that caused + an error. */ + +#if BUILT_FOR_270 +void +lang_print_error_function (file) + char *file; +{ + static ffesymbol last_s = NULL; + ffesymbol s; + char *kind; + + if (ffecom_primary_entry_ == NULL) + { + s = NULL; + kind = NULL; + } + else if (ffecom_nested_entry_ == NULL) + { + s = ffecom_primary_entry_; + switch (ffesymbol_kind (s)) + { + case FFEINFO_kindFUNCTION: + kind = "function"; + break; + + case FFEINFO_kindSUBROUTINE: + kind = "subroutine"; + break; + + case FFEINFO_kindPROGRAM: + kind = "program"; + break; + + case FFEINFO_kindBLOCKDATA: + kind = "block-data"; + break; + + default: + kind = ffeinfo_kind_message (ffesymbol_kind (s)); + break; + } + } + else + { + s = ffecom_nested_entry_; + kind = "statement function"; + } + + if (last_s != s) + { + if (file) + fprintf (stderr, "%s: ", file); + + if (s == NULL) + fprintf (stderr, "Outside of any program unit:\n"); + else + { + char *name = ffesymbol_text (s); + + fprintf (stderr, "In %s `%s':\n", kind, name); + } + + last_s = s; + } +} +#endif + +/* Similar to `lookup_name' but look only at current binding level. */ + +static tree +lookup_name_current_level (tree name) +{ + register tree t; + + if (current_binding_level == global_binding_level) + return IDENTIFIER_GLOBAL_VALUE (name); + + if (IDENTIFIER_LOCAL_VALUE (name) == 0) + return 0; + + for (t = current_binding_level->names; t; t = TREE_CHAIN (t)) + if (DECL_NAME (t) == name) + break; + + return t; +} + +/* Create a new `struct binding_level'. */ + +static struct binding_level * +make_binding_level () +{ + /* NOSTRICT */ + return (struct binding_level *) xmalloc (sizeof (struct binding_level)); +} + +/* Save and restore the variables in this file and elsewhere + that keep track of the progress of compilation of the current function. + Used for nested functions. */ + +struct f_function +{ + struct f_function *next; + tree named_labels; + tree shadowed_labels; + struct binding_level *binding_level; +}; + +struct f_function *f_function_chain; + +/* Restore the variables used during compilation of a C function. */ + +static void +pop_f_function_context () +{ + struct f_function *p = f_function_chain; + tree link; + + /* Bring back all the labels that were shadowed. */ + for (link = shadowed_labels; link; link = TREE_CHAIN (link)) + if (DECL_NAME (TREE_VALUE (link)) != 0) + IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link))) + = TREE_VALUE (link); + + if (DECL_SAVED_INSNS (current_function_decl) == 0) + { + /* Stop pointing to the local nodes about to be freed. */ + /* But DECL_INITIAL must remain nonzero so we know this was an actual + function definition. */ + DECL_INITIAL (current_function_decl) = error_mark_node; + DECL_ARGUMENTS (current_function_decl) = 0; + } + + pop_function_context (); + + f_function_chain = p->next; + + named_labels = p->named_labels; + shadowed_labels = p->shadowed_labels; + current_binding_level = p->binding_level; + + free (p); +} + +/* Save and reinitialize the variables + used during compilation of a C function. */ + +static void +push_f_function_context () +{ + struct f_function *p + = (struct f_function *) xmalloc (sizeof (struct f_function)); + + push_function_context (); + + p->next = f_function_chain; + f_function_chain = p; + + p->named_labels = named_labels; + p->shadowed_labels = shadowed_labels; + p->binding_level = current_binding_level; +} + +static void +push_parm_decl (tree parm) +{ + int old_immediate_size_expand = immediate_size_expand; + + /* Don't try computing parm sizes now -- wait till fn is called. */ + + immediate_size_expand = 0; + + push_obstacks_nochange (); + + /* Fill in arg stuff. */ + + DECL_ARG_TYPE (parm) = TREE_TYPE (parm); + DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm); + TREE_READONLY (parm) = 1; /* All implementation args are read-only. */ + + parm = pushdecl (parm); + + immediate_size_expand = old_immediate_size_expand; + + finish_decl (parm, NULL_TREE, FALSE); +} + +/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */ + +static tree +pushdecl_top_level (x) + tree x; +{ + register tree t; + register struct binding_level *b = current_binding_level; + register tree f = current_function_decl; + + current_binding_level = global_binding_level; + current_function_decl = NULL_TREE; + t = pushdecl (x); + current_binding_level = b; + current_function_decl = f; + return t; +} + +/* Store the list of declarations of the current level. + This is done for the parameter declarations of a function being defined, + after they are modified in the light of any missing parameters. */ + +static tree +storedecls (decls) + tree decls; +{ + return current_binding_level->names = decls; +} + +/* Store the parameter declarations into the current function declaration. + This is called after parsing the parameter declarations, before + digesting the body of the function. + + For an old-style definition, modify the function's type + to specify at least the number of arguments. */ + +static void +store_parm_decls (int is_main_program UNUSED) +{ + register tree fndecl = current_function_decl; + + /* This is a chain of PARM_DECLs from old-style parm declarations. */ + DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ())); + + /* Initialize the RTL code for the function. */ + + init_function_start (fndecl, input_filename, lineno); + + /* Set up parameters and prepare for return, for the function. */ + + expand_function_start (fndecl, 0); +} + +static tree +start_decl (tree decl, bool is_top_level) +{ + register tree tem; + bool at_top_level = (current_binding_level == global_binding_level); + bool top_level = is_top_level || at_top_level; + + /* Caller should pass TRUE for is_top_level only if we wouldn't be at top + level anyway. */ + assert (!is_top_level || !at_top_level); + + /* The corresponding pop_obstacks is in finish_decl. */ + push_obstacks_nochange (); + + if (DECL_INITIAL (decl) != NULL_TREE) + { + assert (DECL_INITIAL (decl) == error_mark_node); + assert (!DECL_EXTERNAL (decl)); + } + else if (top_level) + assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1); + + /* For Fortran, we by default put things in .common when possible. */ + DECL_COMMON (decl) = 1; + + /* Add this decl to the current binding level. TEM may equal DECL or it may + be a previous decl of the same name. */ + if (is_top_level) + tem = pushdecl_top_level (decl); + else + tem = pushdecl (decl); + + /* For a local variable, define the RTL now. */ + if (!top_level + /* But not if this is a duplicate decl and we preserved the rtl from the + previous one (which may or may not happen). */ + && DECL_RTL (tem) == 0) + { + if (TYPE_SIZE (TREE_TYPE (tem)) != 0) + expand_decl (tem); + else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE + && DECL_INITIAL (tem) != 0) + expand_decl (tem); + } + + if (DECL_INITIAL (tem) != NULL_TREE) + { + /* When parsing and digesting the initializer, use temporary storage. + Do this even if we will ignore the value. */ + if (at_top_level) + temporary_allocation (); + } + + return tem; +} + +/* Create the FUNCTION_DECL for a function definition. + DECLSPECS and DECLARATOR are the parts of the declaration; + they describe the function's name and the type it returns, + but twisted together in a fashion that parallels the syntax of C. + + This function creates a binding context for the function body + as well as setting up the FUNCTION_DECL in current_function_decl. + + Returns 1 on success. If the DECLARATOR is not suitable for a function + (it defines a datum instead), we return 0, which tells + yyparse to report a parse error. + + NESTED is nonzero for a function nested within another function. */ + +static void +start_function (tree name, tree type, int nested, int public) +{ + tree decl1; + tree restype; + int old_immediate_size_expand = immediate_size_expand; + + named_labels = 0; + shadowed_labels = 0; + + /* Don't expand any sizes in the return type of the function. */ + immediate_size_expand = 0; + + if (nested) + { + assert (!public); + assert (current_function_decl != NULL_TREE); + assert (DECL_CONTEXT (current_function_decl) == NULL_TREE); + } + else + { + assert (current_function_decl == NULL_TREE); + } + + decl1 = build_decl (FUNCTION_DECL, + name, + type); + TREE_PUBLIC (decl1) = public ? 1 : 0; + if (nested) + DECL_INLINE (decl1) = 1; + TREE_STATIC (decl1) = 1; + DECL_EXTERNAL (decl1) = 0; + + announce_function (decl1); + + /* Make the init_value nonzero so pushdecl knows this is not tentative. + error_mark_node is replaced below (in poplevel) with the BLOCK. */ + DECL_INITIAL (decl1) = error_mark_node; + + /* Record the decl so that the function name is defined. If we already have + a decl for this name, and it is a FUNCTION_DECL, use the old decl. */ + + current_function_decl = pushdecl (decl1); + if (!nested) + ffecom_outer_function_decl_ = current_function_decl; + + pushlevel (0); + + make_function_rtl (current_function_decl); + + restype = TREE_TYPE (TREE_TYPE (current_function_decl)); + DECL_RESULT (current_function_decl) + = build_decl (RESULT_DECL, NULL_TREE, restype); + + if (!nested) + /* Allocate further tree nodes temporarily during compilation of this + function only. */ + temporary_allocation (); + + if (!nested) + TREE_ADDRESSABLE (current_function_decl) = 1; + + immediate_size_expand = old_immediate_size_expand; +} + +/* Here are the public functions the GNU back end needs. */ + +/* This is used by the `assert' macro. It is provided in libgcc.a, + which `cc' doesn't know how to link. Note that the C++ front-end + no longer actually uses the `assert' macro (instead, it calls + my_friendly_assert). But all of the back-end files still need this. */ +void +__eprintf (string, expression, line, filename) +#ifdef __STDC__ + const char *string; + const char *expression; + unsigned line; + const char *filename; +#else + char *string; + char *expression; + unsigned line; + char *filename; +#endif +{ + fprintf (stderr, string, expression, line, filename); + fflush (stderr); + abort (); +} + +tree +convert (type, expr) + tree type, expr; +{ + register tree e = expr; + register enum tree_code code = TREE_CODE (type); + + if (type == TREE_TYPE (e) + || TREE_CODE (e) == ERROR_MARK) + return e; + if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e))) + return fold (build1 (NOP_EXPR, type, e)); + if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK + || code == ERROR_MARK) + return error_mark_node; + if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE) + { + assert ("void value not ignored as it ought to be" == NULL); + return error_mark_node; + } + if (code == VOID_TYPE) + return build1 (CONVERT_EXPR, type, e); + if ((code != RECORD_TYPE) + && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE)) + e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))), + e); + if (code == INTEGER_TYPE || code == ENUMERAL_TYPE) + return fold (convert_to_integer (type, e)); + if (code == POINTER_TYPE) + return fold (convert_to_pointer (type, e)); + if (code == REAL_TYPE) + return fold (convert_to_real (type, e)); + if (code == COMPLEX_TYPE) + return fold (convert_to_complex (type, e)); + if (code == RECORD_TYPE) + return fold (ffecom_convert_to_complex_ (type, e)); + + assert ("conversion to non-scalar type requested" == NULL); + return error_mark_node; +} + +/* integrate_decl_tree calls this function, but since we don't use the + DECL_LANG_SPECIFIC field, this is a no-op. */ + +void +copy_lang_decl (node) + tree node UNUSED; +{ +} + +/* Return the list of declarations of the current level. + Note that this list is in reverse order unless/until + you nreverse it; and when you do nreverse it, you must + store the result back using `storedecls' or you will lose. */ + +tree +getdecls () +{ + return current_binding_level->names; +} + +/* Nonzero if we are currently in the global binding level. */ + +int +global_bindings_p () +{ + return current_binding_level == global_binding_level; +} + +/* Insert BLOCK at the end of the list of subblocks of the + current binding level. This is used when a BIND_EXPR is expanded, + to handle the BLOCK node inside the BIND_EXPR. */ + +void +incomplete_type_error (value, type) + tree value UNUSED; + tree type; +{ + if (TREE_CODE (type) == ERROR_MARK) + return; + + assert ("incomplete type?!?" == NULL); +} + +void +init_decl_processing () +{ + malloc_init (); + ffe_init_0 (); +} + +void +init_lex () +{ +#if BUILT_FOR_270 + extern void (*print_error_function) (char *); +#endif + + /* 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 +} + +void +insert_block (block) + tree block; +{ + TREE_USED (block) = 1; + current_binding_level->blocks + = chainon (current_binding_level->blocks, block); +} + +int +lang_decode_option (p) + char *p; +{ + return ffe_decode_option (p); +} + +void +lang_finish () +{ + ffe_terminate_0 (); + + if (ffe_is_ffedebug ()) + malloc_pool_display (malloc_pool_image ()); +} + +char * +lang_identify () +{ + return "f77"; +} + +void +lang_init () +{ + extern FILE *finput; /* Don't pollute com.h with this. */ + + /* If the file is output from cpp, it should contain a first line + `# 1 "real-filename"', and the current design of gcc (toplev.c + in particular and the way it sets up information relied on by + INCLUDE) requires that we read this now, and store the + "real-filename" info in master_input_filename. Ask the lexer + to try doing this. */ + ffelex_hash_kludge (finput); +} + +int +mark_addressable (exp) + tree exp; +{ + register tree x = exp; + while (1) + switch (TREE_CODE (x)) + { + case ADDR_EXPR: + case COMPONENT_REF: + case ARRAY_REF: + x = TREE_OPERAND (x, 0); + break; + + case CONSTRUCTOR: + TREE_ADDRESSABLE (x) = 1; + return 1; + + case VAR_DECL: + case CONST_DECL: + case PARM_DECL: + case RESULT_DECL: + if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) + && DECL_NONLOCAL (x)) + { + if (TREE_PUBLIC (x)) + { + assert ("address of global register var requested" == NULL); + return 0; + } + assert ("address of register variable requested" == NULL); + } + else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)) + { + if (TREE_PUBLIC (x)) + { + assert ("address of global register var requested" == NULL); + return 0; + } + assert ("address of register var requested" == NULL); + } + put_var_into_stack (x); + + /* drops in */ + case FUNCTION_DECL: + TREE_ADDRESSABLE (x) = 1; +#if 0 /* poplevel deals with this now. */ + if (DECL_CONTEXT (x) == 0) + TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1; +#endif + + default: + return 1; + } +} + +/* If DECL has a cleanup, build and return that cleanup here. + This is a callback called by expand_expr. */ + +tree +maybe_build_cleanup (decl) + tree decl UNUSED; +{ + /* There are no cleanups in Fortran. */ + return NULL_TREE; +} + +/* Exit a binding level. + Pop the level off, and restore the state of the identifier-decl mappings + that were in effect when this level was entered. + + If KEEP is nonzero, this level had explicit declarations, so + and create a "block" (a BLOCK node) for the level + to record its declarations and subblocks for symbol table output. + + If FUNCTIONBODY is nonzero, this level is the body of a function, + so create a block as if KEEP were set and also clear out all + label names. + + If REVERSE is nonzero, reverse the order of decls before putting + them into the BLOCK. */ + +tree +poplevel (keep, reverse, functionbody) + int keep; + int reverse; + int functionbody; +{ + register tree link; + /* The chain of decls was accumulated in reverse order. Put it into forward + order, just for cleanliness. */ + tree decls; + tree subblocks = current_binding_level->blocks; + tree block = 0; + tree decl; + int block_previously_created; + + /* Get the decls in the order they were written. Usually + current_binding_level->names is in reverse order. But parameter decls + were previously put in forward order. */ + + if (reverse) + current_binding_level->names + = decls = nreverse (current_binding_level->names); + else + decls = current_binding_level->names; + + /* Output any nested inline functions within this block if they weren't + already output. */ + + for (decl = decls; decl; decl = TREE_CHAIN (decl)) + if (TREE_CODE (decl) == FUNCTION_DECL + && !TREE_ASM_WRITTEN (decl) + && DECL_INITIAL (decl) != 0 + && TREE_ADDRESSABLE (decl)) + { + /* If this decl was copied from a file-scope decl on account of a + block-scope extern decl, propagate TREE_ADDRESSABLE to the + file-scope decl. */ + if (DECL_ABSTRACT_ORIGIN (decl) != 0) + TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1; + else + { + push_function_context (); + output_inline_function (decl); + pop_function_context (); + } + } + + /* If there were any declarations or structure tags in that level, or if + this level is a function body, create a BLOCK to record them for the + life of this function. */ + + block = 0; + block_previously_created = (current_binding_level->this_block != 0); + if (block_previously_created) + block = current_binding_level->this_block; + else if (keep || functionbody) + block = make_node (BLOCK); + if (block != 0) + { + BLOCK_VARS (block) = decls; + BLOCK_SUBBLOCKS (block) = subblocks; + remember_end_note (block); + } + + /* In each subblock, record that this is its superior. */ + + for (link = subblocks; link; link = TREE_CHAIN (link)) + BLOCK_SUPERCONTEXT (link) = block; + + /* Clear out the meanings of the local variables of this level. */ + + for (link = decls; link; link = TREE_CHAIN (link)) + { + if (DECL_NAME (link) != 0) + { + /* If the ident. was used or addressed via a local extern decl, + don't forget that fact. */ + if (DECL_EXTERNAL (link)) + { + if (TREE_USED (link)) + TREE_USED (DECL_NAME (link)) = 1; + if (TREE_ADDRESSABLE (link)) + TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1; + } + IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0; + } + } + + /* If the level being exited is the top level of a function, check over all + the labels, and clear out the current (function local) meanings of their + names. */ + + if (functionbody) + { + /* If this is the top level block of a function, the vars are the + function's parameters. Don't leave them in the BLOCK because they + are found in the FUNCTION_DECL instead. */ + + BLOCK_VARS (block) = 0; + } + + /* Pop the current level, and free the structure for reuse. */ + + { + register struct binding_level *level = current_binding_level; + current_binding_level = current_binding_level->level_chain; + + level->level_chain = free_binding_level; + free_binding_level = level; + } + + /* Dispose of the block that we just made inside some higher level. */ + if (functionbody) + DECL_INITIAL (current_function_decl) = block; + else if (block) + { + if (!block_previously_created) + current_binding_level->blocks + = chainon (current_binding_level->blocks, block); + } + /* If we did not make a block for the level just exited, any blocks made + for inner levels (since they cannot be recorded as subblocks in that + level) must be carried forward so they will later become subblocks of + something else. */ + else if (subblocks) + current_binding_level->blocks + = chainon (current_binding_level->blocks, subblocks); + + /* Set the TYPE_CONTEXTs for all of the tagged types belonging to this + binding contour so that they point to the appropriate construct, i.e. + either to the current FUNCTION_DECL node, or else to the BLOCK node we + just constructed. + + Note that for tagged types whose scope is just the formal parameter list + for some function type specification, we can't properly set their + TYPE_CONTEXTs here, because we don't have a pointer to the appropriate + FUNCTION_TYPE node readily available to us. For those cases, the + TYPE_CONTEXTs of the relevant tagged type nodes get set in + `grokdeclarator' as soon as we have created the FUNCTION_TYPE node which + will represent the "scope" for these "parameter list local" tagged + types. */ + + if (block) + TREE_USED (block) = 1; + return block; +} + +void +print_lang_decl (file, node, indent) + FILE *file UNUSED; + tree node UNUSED; + int indent UNUSED; +{ +} + +void +print_lang_identifier (file, node, indent) + FILE *file; + tree node; + int indent; +{ + print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4); + print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4); +} + +void +print_lang_statistics () +{ +} + +void +print_lang_type (file, node, indent) + FILE *file UNUSED; + tree node UNUSED; + int indent UNUSED; +{ +} + +/* Record a decl-node X as belonging to the current lexical scope. + Check for errors (such as an incompatible declaration for the same + name already seen in the same scope). + + Returns either X or an old decl for the same name. + If an old decl is returned, it may have been smashed + to agree with what X says. */ + +tree +pushdecl (x) + tree x; +{ + register tree t; + register tree name = DECL_NAME (x); + register struct binding_level *b = current_binding_level; + + if ((TREE_CODE (x) == FUNCTION_DECL) + && (DECL_INITIAL (x) == 0) + && DECL_EXTERNAL (x)) + DECL_CONTEXT (x) = NULL_TREE; + else + DECL_CONTEXT (x) = current_function_decl; + + if (name) + { + if (IDENTIFIER_INVENTED (name)) + { +#if BUILT_FOR_270 + DECL_ARTIFICIAL (x) = 1; +#endif + DECL_IN_SYSTEM_HEADER (x) = 1; + DECL_IGNORED_P (x) = 1; + TREE_USED (x) = 1; + if (TREE_CODE (x) == TYPE_DECL) + TYPE_DECL_SUPPRESS_DEBUG (x) = 1; + } + + t = lookup_name_current_level (name); + + assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE)); + + /* Don't push non-parms onto list for parms until we understand + why we're doing this and whether it works. */ + + assert ((b == global_binding_level) + || !ffecom_transform_only_dummies_ + || TREE_CODE (x) == PARM_DECL); + + if ((t != NULL_TREE) && duplicate_decls (x, t)) + return t; + + /* If we are processing a typedef statement, generate a whole new + ..._TYPE node (which will be just an variant of the existing + ..._TYPE node with identical properties) and then install the + TYPE_DECL node generated to represent the typedef name as the + TYPE_NAME of this brand new (duplicate) ..._TYPE node. + + The whole point here is to end up with a situation where each and every + ..._TYPE node the compiler creates will be uniquely associated with + AT MOST one node representing a typedef name. This way, even though + the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL + (i.e. "typedef name") nodes very early on, later parts of the + compiler can always do the reverse translation and get back the + corresponding typedef name. For example, given: + + typedef struct S MY_TYPE; MY_TYPE object; + + Later parts of the compiler might only know that `object' was of type + `struct S' if if were not for code just below. With this code + however, later parts of the compiler see something like: + + struct S' == struct S typedef struct S' MY_TYPE; struct S' object; + + And they can then deduce (from the node for type struct S') that the + original object declaration was: + + MY_TYPE object; + + Being able to do this is important for proper support of protoize, and + also for generating precise symbolic debugging information which + takes full account of the programmer's (typedef) vocabulary. + + Obviously, we don't want to generate a duplicate ..._TYPE node if the + TYPE_DECL node that we are now processing really represents a + standard built-in type. + + Since all standard types are effectively declared at line zero in the + source file, we can easily check to see if we are working on a + standard type by checking the current value of lineno. */ + + if (TREE_CODE (x) == TYPE_DECL) + { + if (DECL_SOURCE_LINE (x) == 0) + { + if (TYPE_NAME (TREE_TYPE (x)) == 0) + TYPE_NAME (TREE_TYPE (x)) = x; + } + else if (TREE_TYPE (x) != error_mark_node) + { + tree tt = TREE_TYPE (x); + + tt = build_type_copy (tt); + TYPE_NAME (tt) = x; + TREE_TYPE (x) = tt; + } + } + + /* This name is new in its binding level. Install the new declaration + and return it. */ + if (b == global_binding_level) + IDENTIFIER_GLOBAL_VALUE (name) = x; + else + IDENTIFIER_LOCAL_VALUE (name) = x; + } + + /* Put decls on list in reverse order. We will reverse them later if + necessary. */ + TREE_CHAIN (x) = b->names; + b->names = x; + + return x; +} + +/* Enter a new binding level. + If TAG_TRANSPARENT is nonzero, do so only for the name space of variables, + not for that of tags. */ + +void +pushlevel (tag_transparent) + int tag_transparent; +{ + register struct binding_level *newlevel = NULL_BINDING_LEVEL; + + assert (!tag_transparent); + + /* Reuse or create a struct for this binding level. */ + + if (free_binding_level) + { + newlevel = free_binding_level; + free_binding_level = free_binding_level->level_chain; + } + else + { + newlevel = make_binding_level (); + } + + /* Add this level to the front of the chain (stack) of levels that are + active. */ + + *newlevel = clear_binding_level; + newlevel->level_chain = current_binding_level; + current_binding_level = newlevel; +} + +/* Set the BLOCK node for the innermost scope + (the one we are currently in). */ + +void +set_block (block) + register tree block; +{ + current_binding_level->this_block = block; +} + +/* ~~tree.h SHOULD declare this, because toplev.c references it. */ + +/* Can't 'yydebug' a front end not generated by yacc/bison! */ + +void +set_yydebug (value) + int value; +{ + if (value) + fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n"); +} + +tree +signed_or_unsigned_type (unsignedp, type) + int unsignedp; + tree type; +{ + tree type2; + + if (! INTEGRAL_TYPE_P (type)) + return type; + if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node)) + return unsignedp ? unsigned_char_type_node : signed_char_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node)) + return unsignedp ? unsigned_type_node : integer_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node)) + return unsignedp ? short_unsigned_type_node : short_integer_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node)) + return unsignedp ? long_unsigned_type_node : long_integer_type_node; + if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node)) + return (unsignedp ? long_long_unsigned_type_node + : long_long_integer_type_node); + + type2 = type_for_size (TYPE_PRECISION (type), unsignedp); + if (type2 == NULL_TREE) + return type; + + return type2; +} + +tree +signed_type (type) + tree type; +{ + tree type1 = TYPE_MAIN_VARIANT (type); + ffeinfoKindtype kt; + tree type2; + + if (type1 == unsigned_char_type_node || type1 == char_type_node) + return signed_char_type_node; + if (type1 == unsigned_type_node) + return integer_type_node; + if (type1 == short_unsigned_type_node) + return short_integer_type_node; + if (type1 == long_unsigned_type_node) + return long_integer_type_node; + if (type1 == long_long_unsigned_type_node) + return long_long_integer_type_node; +#if 0 /* gcc/c-* files only */ + if (type1 == unsigned_intDI_type_node) + return intDI_type_node; + if (type1 == unsigned_intSI_type_node) + return intSI_type_node; + if (type1 == unsigned_intHI_type_node) + return intHI_type_node; + if (type1 == unsigned_intQI_type_node) + return intQI_type_node; +#endif + + type2 = type_for_size (TYPE_PRECISION (type1), 0); + if (type2 != NULL_TREE) + return type2; + + for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt) + { + type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; + + if (type1 == type2) + return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt]; + } + + return type; +} + +/* Prepare expr to be an argument of a TRUTH_NOT_EXPR, + or validate its data type for an `if' or `while' statement or ?..: exp. + + This preparation consists of taking the ordinary + representation of an expression expr and producing a valid tree + boolean expression describing whether expr is nonzero. We could + simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1), + but we optimize comparisons, &&, ||, and !. + + The resulting type should always be `integer_type_node'. */ + +tree +truthvalue_conversion (expr) + tree expr; +{ + if (TREE_CODE (expr) == ERROR_MARK) + return expr; + +#if 0 /* This appears to be wrong for C++. */ + /* These really should return error_mark_node after 2.4 is stable. + But not all callers handle ERROR_MARK properly. */ + switch (TREE_CODE (TREE_TYPE (expr))) + { + case RECORD_TYPE: + error ("struct type value used where scalar is required"); + return integer_zero_node; + + case UNION_TYPE: + error ("union type value used where scalar is required"); + return integer_zero_node; + + case ARRAY_TYPE: + error ("array type value used where scalar is required"); + return integer_zero_node; + + default: + break; + } +#endif /* 0 */ + + switch (TREE_CODE (expr)) + { + /* It is simpler and generates better code to have only TRUTH_*_EXPR + or comparison expressions as truth values at this level. */ +#if 0 + case COMPONENT_REF: + /* A one-bit unsigned bit-field is already acceptable. */ + if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1))) + && TREE_UNSIGNED (TREE_OPERAND (expr, 1))) + return expr; + break; +#endif + + case EQ_EXPR: + /* It is simpler and generates better code to have only TRUTH_*_EXPR + or comparison expressions as truth values at this level. */ +#if 0 + if (integer_zerop (TREE_OPERAND (expr, 1))) + return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0); +#endif + case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR: + case TRUTH_ANDIF_EXPR: + case TRUTH_ORIF_EXPR: + case TRUTH_AND_EXPR: + case TRUTH_OR_EXPR: + case TRUTH_XOR_EXPR: + TREE_TYPE (expr) = integer_type_node; + return expr; + + case ERROR_MARK: + return expr; + + case INTEGER_CST: + return integer_zerop (expr) ? integer_zero_node : integer_one_node; + + case REAL_CST: + return real_zerop (expr) ? integer_zero_node : integer_one_node; + + case ADDR_EXPR: + if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0))) + return build (COMPOUND_EXPR, integer_type_node, + TREE_OPERAND (expr, 0), integer_one_node); + else + return integer_one_node; + + case COMPLEX_EXPR: + return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)) + ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR), + integer_type_node, + truthvalue_conversion (TREE_OPERAND (expr, 0)), + truthvalue_conversion (TREE_OPERAND (expr, 1))); + + case NEGATE_EXPR: + case ABS_EXPR: + case FLOAT_EXPR: + case FFS_EXPR: + /* These don't change whether an object is non-zero or zero. */ + return truthvalue_conversion (TREE_OPERAND (expr, 0)); + + case LROTATE_EXPR: + case RROTATE_EXPR: + /* These don't change whether an object is zero or non-zero, but + we can't ignore them if their second arg has side-effects. */ + if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))) + return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1), + truthvalue_conversion (TREE_OPERAND (expr, 0))); + else + return truthvalue_conversion (TREE_OPERAND (expr, 0)); + + case COND_EXPR: + /* Distribute the conversion into the arms of a COND_EXPR. */ + return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0), + truthvalue_conversion (TREE_OPERAND (expr, 1)), + truthvalue_conversion (TREE_OPERAND (expr, 2)))); + + case CONVERT_EXPR: + /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE, + since that affects how `default_conversion' will behave. */ + if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE + || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE) + break; + /* fall through... */ + case NOP_EXPR: + /* If this is widening the argument, we can ignore it. */ + if (TYPE_PRECISION (TREE_TYPE (expr)) + >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0)))) + return truthvalue_conversion (TREE_OPERAND (expr, 0)); + break; + + case MINUS_EXPR: + /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize + this case. */ + if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT + && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE) + break; + /* fall through... */ + case BIT_XOR_EXPR: + /* This and MINUS_EXPR can be changed into a comparison of the + two objects. */ + if (TREE_TYPE (TREE_OPERAND (expr, 0)) + == TREE_TYPE (TREE_OPERAND (expr, 1))) + return ffecom_2 (NE_EXPR, integer_type_node, + TREE_OPERAND (expr, 0), + TREE_OPERAND (expr, 1)); + return ffecom_2 (NE_EXPR, integer_type_node, + TREE_OPERAND (expr, 0), + fold (build1 (NOP_EXPR, + TREE_TYPE (TREE_OPERAND (expr, 0)), + TREE_OPERAND (expr, 1)))); + + case BIT_AND_EXPR: + if (integer_onep (TREE_OPERAND (expr, 1))) + return expr; + break; + + case MODIFY_EXPR: +#if 0 /* No such thing in Fortran. */ + if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR) + warning ("suggest parentheses around assignment used as truth value"); +#endif + break; + + default: + break; + } + + if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE) + return (ffecom_2 + ((TREE_SIDE_EFFECTS (expr) + ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR), + integer_type_node, + truthvalue_conversion (ffecom_1 (REALPART_EXPR, + TREE_TYPE (TREE_TYPE (expr)), + expr)), + truthvalue_conversion (ffecom_1 (IMAGPART_EXPR, + TREE_TYPE (TREE_TYPE (expr)), + expr)))); + + return ffecom_2 (NE_EXPR, integer_type_node, + expr, + convert (TREE_TYPE (expr), integer_zero_node)); +} + +tree +type_for_mode (mode, unsignedp) + enum machine_mode mode; + int unsignedp; +{ + int i; + int j; + tree t; + + if (mode == TYPE_MODE (integer_type_node)) + return unsignedp ? unsigned_type_node : integer_type_node; + + if (mode == TYPE_MODE (signed_char_type_node)) + return unsignedp ? unsigned_char_type_node : signed_char_type_node; + + if (mode == TYPE_MODE (short_integer_type_node)) + return unsignedp ? short_unsigned_type_node : short_integer_type_node; + + if (mode == TYPE_MODE (long_integer_type_node)) + return unsignedp ? long_unsigned_type_node : long_integer_type_node; + + if (mode == TYPE_MODE (long_long_integer_type_node)) + return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node; + + if (mode == TYPE_MODE (float_type_node)) + return float_type_node; + + if (mode == TYPE_MODE (double_type_node)) + return double_type_node; + + if (mode == TYPE_MODE (build_pointer_type (char_type_node))) + return build_pointer_type (char_type_node); + + if (mode == TYPE_MODE (build_pointer_type (integer_type_node))) + return build_pointer_type (integer_type_node); + + for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i) + for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j) + { + if (((t = ffecom_tree_type[i][j]) != NULL_TREE) + && (mode == TYPE_MODE (t))) + if ((i == FFEINFO_basictypeINTEGER) && unsignedp) + return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j]; + else + return t; + } + + return 0; +} + +tree +type_for_size (bits, unsignedp) + unsigned bits; + int unsignedp; +{ + ffeinfoKindtype kt; + tree type_node; + + if (bits == TYPE_PRECISION (integer_type_node)) + return unsignedp ? unsigned_type_node : integer_type_node; + + if (bits == TYPE_PRECISION (signed_char_type_node)) + return unsignedp ? unsigned_char_type_node : signed_char_type_node; + + if (bits == TYPE_PRECISION (short_integer_type_node)) + return unsignedp ? short_unsigned_type_node : short_integer_type_node; + + if (bits == TYPE_PRECISION (long_integer_type_node)) + return unsignedp ? long_unsigned_type_node : long_integer_type_node; + + if (bits == TYPE_PRECISION (long_long_integer_type_node)) + return (unsignedp ? long_long_unsigned_type_node + : long_long_integer_type_node); + + for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt) + { + type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt]; + + if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node))) + return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt] + : type_node; + } + + return 0; +} + +tree +unsigned_type (type) + tree type; +{ + tree type1 = TYPE_MAIN_VARIANT (type); + ffeinfoKindtype kt; + tree type2; + + if (type1 == signed_char_type_node || type1 == char_type_node) + return unsigned_char_type_node; + if (type1 == integer_type_node) + return unsigned_type_node; + if (type1 == short_integer_type_node) + return short_unsigned_type_node; + if (type1 == long_integer_type_node) + return long_unsigned_type_node; + if (type1 == long_long_integer_type_node) + return long_long_unsigned_type_node; +#if 0 /* gcc/c-* files only */ + if (type1 == intDI_type_node) + return unsigned_intDI_type_node; + if (type1 == intSI_type_node) + return unsigned_intSI_type_node; + if (type1 == intHI_type_node) + return unsigned_intHI_type_node; + if (type1 == intQI_type_node) + return unsigned_intQI_type_node; +#endif + + type2 = type_for_size (TYPE_PRECISION (type1), 1); + if (type2 != NULL_TREE) + return type2; + + for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt) + { + type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt]; + + if (type1 == type2) + return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]; + } + + return type; +} + +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + +#if FFECOM_GCC_INCLUDE + +/* From gcc/cccp.c, the code to handle -I. */ + +/* Skip leading "./" from a directory name. + This may yield the empty string, which represents the current directory. */ + +static char * +skip_redundant_dir_prefix (char *dir) +{ + while (dir[0] == '.' && dir[1] == '/') + for (dir += 2; *dir == '/'; dir++) + continue; + if (dir[0] == '.' && !dir[1]) + dir++; + return dir; +} + +/* The file_name_map structure holds a mapping of file names for a + particular directory. This mapping is read from the file named + FILE_NAME_MAP_FILE in that directory. Such a file can be used to + map filenames on a file system with severe filename restrictions, + such as DOS. The format of the file name map file is just a series + of lines with two tokens on each line. The first token is the name + to map, and the second token is the actual name to use. */ + +struct file_name_map +{ + struct file_name_map *map_next; + char *map_from; + char *map_to; +}; + +#define FILE_NAME_MAP_FILE "header.gcc" + +/* Current maximum length of directory names in the search path + for include files. (Altered as we get more of them.) */ + +static int max_include_len = 0; + +struct file_name_list + { + struct file_name_list *next; + char *fname; + /* Mapping of file names for this directory. */ + struct file_name_map *name_map; + /* Non-zero if name_map is valid. */ + int got_name_map; + }; + +static struct file_name_list *include = NULL; /* First dir to search */ +static struct file_name_list *last_include = NULL; /* Last in chain */ + +/* I/O buffer structure. + The `fname' field is nonzero for source files and #include files + and for the dummy text used for -D and -U. + It is zero for rescanning results of macro expansion + and for expanding macro arguments. */ +#define INPUT_STACK_MAX 400 +static struct file_buf { + char *fname; + /* Filename specified with #line command. */ + char *nominal_fname; + /* Record where in the search path this file was found. + For #include_next. */ + struct file_name_list *dir; + ffewhereLine line; + ffewhereColumn column; +} instack[INPUT_STACK_MAX]; + +static int last_error_tick = 0; /* Incremented each time we print it. */ +static int input_file_stack_tick = 0; /* Incremented when status changes. */ + +/* Current nesting level of input sources. + `instack[indepth]' is the level currently being read. */ +static int indepth = -1; + +typedef struct file_buf FILE_BUF; + +typedef unsigned char U_CHAR; + +/* table to tell if char can be part of a C identifier. */ +U_CHAR is_idchar[256]; +/* table to tell if char can be first char of a c identifier. */ +U_CHAR is_idstart[256]; +/* table to tell if c is horizontal space. */ +U_CHAR is_hor_space[256]; +/* table to tell if c is horizontal or vertical space. */ +static U_CHAR is_space[256]; + +#define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0) +#define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0) + +/* Nonzero means -I- has been seen, + so don't look for #include "foo" the source-file directory. */ +static int ignore_srcdir; + +#ifndef INCLUDE_LEN_FUDGE +#define INCLUDE_LEN_FUDGE 0 +#endif + +static void append_include_chain (struct file_name_list *first, + struct file_name_list *last); +static FILE *open_include_file (char *filename, + struct file_name_list *searchptr); +static void print_containing_files (ffebadSeverity sev); +static char *skip_redundant_dir_prefix (char *); +static char *read_filename_string (int ch, FILE *f); +static struct file_name_map *read_name_map (char *dirname); +static char *savestring (char *input); + +/* Append a chain of `struct file_name_list's + to the end of the main include chain. + FIRST is the beginning of the chain to append, and LAST is the end. */ + +static void +append_include_chain (first, last) + struct file_name_list *first, *last; +{ + struct file_name_list *dir; + + if (!first || !last) + return; + + if (include == 0) + include = first; + else + last_include->next = first; + + for (dir = first; ; dir = dir->next) { + int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE; + if (len > max_include_len) + max_include_len = len; + if (dir == last) + break; + } + + last->next = NULL; + last_include = last; +} + +/* Try to open include file FILENAME. SEARCHPTR is the directory + being tried from the include file search path. This function maps + filenames on file systems based on information read by + read_name_map. */ + +static FILE * +open_include_file (filename, searchptr) + char *filename; + struct file_name_list *searchptr; +{ + register struct file_name_map *map; + register char *from; + char *p, *dir; + + if (searchptr && ! searchptr->got_name_map) + { + searchptr->name_map = read_name_map (searchptr->fname + ? searchptr->fname : "."); + searchptr->got_name_map = 1; + } + + /* First check the mapping for the directory we are using. */ + if (searchptr && searchptr->name_map) + { + from = filename; + if (searchptr->fname) + from += strlen (searchptr->fname) + 1; + for (map = searchptr->name_map; map; map = map->map_next) + { + if (! strcmp (map->map_from, from)) + { + /* Found a match. */ + return fopen (map->map_to, "r"); + } + } + } + + /* Try to find a mapping file for the particular directory we are + looking in. Thus #include will look up sys/types.h + in /usr/include/header.gcc and look up types.h in + /usr/include/sys/header.gcc. */ + p = rindex (filename, '/'); +#ifdef DIR_SEPARATOR + if (! p) p = rindex (filename, DIR_SEPARATOR); + else { + char *tmp = rindex (filename, DIR_SEPARATOR); + if (tmp != NULL && tmp > p) p = tmp; + } +#endif + if (! p) + p = filename; + if (searchptr + && searchptr->fname + && strlen (searchptr->fname) == (size_t) (p - filename) + && ! strncmp (searchptr->fname, filename, (int) (p - filename))) + { + /* FILENAME is in SEARCHPTR, which we've already checked. */ + return fopen (filename, "r"); + } + + if (p == filename) + { + from = filename; + map = read_name_map ("."); + } + else + { + dir = (char *) xmalloc (p - filename + 1); + bcopy (filename, dir, p - filename); + dir[p - filename] = '\0'; + from = p + 1; + map = read_name_map (dir); + free (dir); + } + for (; map; map = map->map_next) + if (! strcmp (map->map_from, from)) + return fopen (map->map_to, "r"); + + return fopen (filename, "r"); +} + +/* Print the file names and line numbers of the #include + commands which led to the current file. */ + +static void +print_containing_files (ffebadSeverity sev) +{ + FILE_BUF *ip = NULL; + int i; + int first = 1; + char *str1; + char *str2; + + /* If stack of files hasn't changed since we last printed + this info, don't repeat it. */ + if (last_error_tick == input_file_stack_tick) + return; + + for (i = indepth; i >= 0; i--) + if (instack[i].fname != NULL) { + ip = &instack[i]; + break; + } + + /* Give up if we don't find a source file. */ + if (ip == NULL) + return; + + /* Find the other, outer source files. */ + for (i--; i >= 0; i--) + if (instack[i].fname != NULL) + { + ip = &instack[i]; + if (first) + { + first = 0; + str1 = "In file included"; + } + else + { + str1 = "... ..."; + } + + if (i == 1) + str2 = ":"; + else + str2 = ""; + + ffebad_start_msg ("%A from %B at %0%C", sev); + ffebad_here (0, ip->line, ip->column); + ffebad_string (str1); + ffebad_string (ip->nominal_fname); + ffebad_string (str2); + ffebad_finish (); + } + + /* Record we have printed the status as of this time. */ + last_error_tick = input_file_stack_tick; +} + +/* Read a space delimited string of unlimited length from a stdio + file. */ + +static char * +read_filename_string (ch, f) + int ch; + FILE *f; +{ + char *alloc, *set; + int len; + + len = 20; + set = alloc = xmalloc (len + 1); + if (! is_space[ch]) + { + *set++ = ch; + while ((ch = getc (f)) != EOF && ! is_space[ch]) + { + if (set - alloc == len) + { + len *= 2; + alloc = xrealloc (alloc, len + 1); + set = alloc + len / 2; + } + *set++ = ch; + } + } + *set = '\0'; + ungetc (ch, f); + return alloc; +} + +/* Read the file name map file for DIRNAME. */ + +static struct file_name_map * +read_name_map (dirname) + char *dirname; +{ + /* This structure holds a linked list of file name maps, one per + directory. */ + struct file_name_map_list + { + struct file_name_map_list *map_list_next; + char *map_list_name; + struct file_name_map *map_list_map; + }; + static struct file_name_map_list *map_list; + register struct file_name_map_list *map_list_ptr; + char *name; + FILE *f; + size_t dirlen; + int separator_needed; + + dirname = skip_redundant_dir_prefix (dirname); + + for (map_list_ptr = map_list; map_list_ptr; + map_list_ptr = map_list_ptr->map_list_next) + if (! strcmp (map_list_ptr->map_list_name, dirname)) + return map_list_ptr->map_list_map; + + map_list_ptr = ((struct file_name_map_list *) + xmalloc (sizeof (struct file_name_map_list))); + map_list_ptr->map_list_name = savestring (dirname); + map_list_ptr->map_list_map = NULL; + + dirlen = strlen (dirname); + separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/'; + name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2); + strcpy (name, dirname); + name[dirlen] = '/'; + strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE); + f = fopen (name, "r"); + free (name); + if (!f) + map_list_ptr->map_list_map = NULL; + else + { + int ch; + + while ((ch = getc (f)) != EOF) + { + char *from, *to; + struct file_name_map *ptr; + + if (is_space[ch]) + continue; + from = read_filename_string (ch, f); + while ((ch = getc (f)) != EOF && is_hor_space[ch]) + ; + to = read_filename_string (ch, f); + + ptr = ((struct file_name_map *) + xmalloc (sizeof (struct file_name_map))); + ptr->map_from = from; + + /* Make the real filename absolute. */ + if (*to == '/') + ptr->map_to = to; + else + { + ptr->map_to = xmalloc (dirlen + strlen (to) + 2); + strcpy (ptr->map_to, dirname); + ptr->map_to[dirlen] = '/'; + strcpy (ptr->map_to + dirlen + separator_needed, to); + free (to); + } + + ptr->map_next = map_list_ptr->map_list_map; + map_list_ptr->map_list_map = ptr; + + while ((ch = getc (f)) != '\n') + if (ch == EOF) + break; + } + fclose (f); + } + + map_list_ptr->map_list_next = map_list; + map_list = map_list_ptr; + + return map_list_ptr->map_list_map; +} + +static char * +savestring (input) + char *input; +{ + unsigned size = strlen (input); + char *output = xmalloc (size + 1); + strcpy (output, input); + return output; +} + +static void +ffecom_file_ (char *name) +{ + FILE_BUF *fp; + + /* Do partial setup of input buffer for the sake of generating + early #line directives (when -g is in effect). */ + + fp = &instack[++indepth]; + bzero ((char *) fp, sizeof (FILE_BUF)); + if (name == NULL) + name = ""; + fp->nominal_fname = fp->fname = name; +} + +/* Initialize syntactic classifications of characters. */ + +static void +ffecom_initialize_char_syntax_ () +{ + register int i; + + /* + * Set up is_idchar and is_idstart tables. These should be + * faster than saying (is_alpha (c) || c == '_'), etc. + * Set up these things before calling any routines tthat + * refer to them. + */ + for (i = 'a'; i <= 'z'; i++) { + is_idchar[i - 'a' + 'A'] = 1; + is_idchar[i] = 1; + is_idstart[i - 'a' + 'A'] = 1; + is_idstart[i] = 1; + } + for (i = '0'; i <= '9'; i++) + is_idchar[i] = 1; + is_idchar['_'] = 1; + is_idstart['_'] = 1; + + /* horizontal space table */ + is_hor_space[' '] = 1; + is_hor_space['\t'] = 1; + is_hor_space['\v'] = 1; + is_hor_space['\f'] = 1; + is_hor_space['\r'] = 1; + + is_space[' '] = 1; + is_space['\t'] = 1; + is_space['\v'] = 1; + is_space['\f'] = 1; + is_space['\n'] = 1; + is_space['\r'] = 1; +} + +static void +ffecom_close_include_ (FILE *f) +{ + fclose (f); + + indepth--; + input_file_stack_tick++; + + ffewhere_line_kill (instack[indepth].line); + ffewhere_column_kill (instack[indepth].column); +} + +static int +ffecom_decode_include_option_ (char *spec) +{ + struct file_name_list *dirtmp; + + if (! ignore_srcdir && !strcmp (spec, "-")) + ignore_srcdir = 1; + else + { + dirtmp = (struct file_name_list *) + xmalloc (sizeof (struct file_name_list)); + dirtmp->next = 0; /* New one goes on the end */ + if (spec[0] != 0) + dirtmp->fname = spec; + else + fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'"); + dirtmp->got_name_map = 0; + append_include_chain (dirtmp, dirtmp); + } + return 1; +} + +/* Open INCLUDEd file. */ + +static FILE * +ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c) +{ + char *fbeg = name; + size_t flen = strlen (fbeg); + struct file_name_list *search_start = include; /* Chain of dirs to search */ + struct file_name_list dsp[1]; /* First in chain, if #include "..." */ + struct file_name_list *searchptr = 0; + char *fname; /* Dynamically allocated fname buffer */ + FILE *f; + FILE_BUF *fp; + + if (flen == 0) + return NULL; + + dsp[0].fname = NULL; + + /* If -I- was specified, don't search current dir, only spec'd ones. */ + if (!ignore_srcdir) + { + for (fp = &instack[indepth]; fp >= instack; fp--) + { + int n; + char *ep; + char *nam; + + if ((nam = fp->nominal_fname) != NULL) + { + /* Found a named file. Figure out dir of the file, + and put it in front of the search list. */ + dsp[0].next = search_start; + search_start = dsp; +#ifndef VMS + ep = rindex (nam, '/'); +#ifdef DIR_SEPARATOR + if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR); + else { + char *tmp = rindex (nam, DIR_SEPARATOR); + if (tmp != NULL && tmp > ep) ep = tmp; + } +#endif +#else /* VMS */ + ep = rindex (nam, ']'); + if (ep == NULL) ep = rindex (nam, '>'); + if (ep == NULL) ep = rindex (nam, ':'); + if (ep != NULL) ep++; +#endif /* VMS */ + if (ep != NULL) + { + n = ep - nam; + dsp[0].fname = (char *) xmalloc (n + 1); + strncpy (dsp[0].fname, nam, n); + dsp[0].fname[n] = '\0'; + if (n + INCLUDE_LEN_FUDGE > max_include_len) + max_include_len = n + INCLUDE_LEN_FUDGE; + } + else + dsp[0].fname = NULL; /* Current directory */ + dsp[0].got_name_map = 0; + break; + } + } + } + + /* Allocate this permanently, because it gets stored in the definitions + of macros. */ + fname = xmalloc (max_include_len + flen + 4); + /* + 2 above for slash and terminating null. */ + /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED + for g77 yet). */ + + /* If specified file name is absolute, just open it. */ + + if (*fbeg == '/' +#ifdef DIR_SEPARATOR + || *fbeg == DIR_SEPARATOR +#endif + ) + { + strncpy (fname, (char *) fbeg, flen); + fname[flen] = 0; + f = open_include_file (fname, NULL_PTR); + } + else + { + f = NULL; + + /* Search directory path, trying to open the file. + Copy each filename tried into FNAME. */ + + for (searchptr = search_start; searchptr; searchptr = searchptr->next) + { + if (searchptr->fname) + { + /* The empty string in a search path is ignored. + This makes it possible to turn off entirely + a standard piece of the list. */ + if (searchptr->fname[0] == 0) + continue; + strcpy (fname, skip_redundant_dir_prefix (searchptr->fname)); + if (fname[0] && fname[strlen (fname) - 1] != '/') + strcat (fname, "/"); + fname[strlen (fname) + flen] = 0; + } + else + fname[0] = 0; + + strncat (fname, fbeg, flen); +#ifdef VMS + /* Change this 1/2 Unix 1/2 VMS file specification into a + full VMS file specification */ + if (searchptr->fname && (searchptr->fname[0] != 0)) + { + /* Fix up the filename */ + hack_vms_include_specification (fname); + } + else + { + /* This is a normal VMS filespec, so use it unchanged. */ + strncpy (fname, (char *) fbeg, flen); + fname[flen] = 0; +#if 0 /* Not for g77. */ + /* if it's '#include filename', add the missing .h */ + if (index (fname, '.') == NULL) + strcat (fname, ".h"); +#endif + } +#endif /* VMS */ + f = open_include_file (fname, searchptr); +#ifdef EACCES + if (f == NULL && errno == EACCES) + { + print_containing_files (FFEBAD_severityWARNING); + ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable", + FFEBAD_severityWARNING); + ffebad_string (fname); + ffebad_here (0, l, c); + ffebad_finish (); + } +#endif + if (f != NULL) + break; + } + } + + if (f == NULL) + { + /* A file that was not found. */ + + strncpy (fname, (char *) fbeg, flen); + fname[flen] = 0; + print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE)); + ffebad_start (FFEBAD_OPEN_INCLUDE); + ffebad_here (0, l, c); + ffebad_string (fname); + ffebad_finish (); + } + + if (dsp[0].fname != NULL) + free (dsp[0].fname); + + if (f == NULL) + return NULL; + + if (indepth >= (INPUT_STACK_MAX - 1)) + { + print_containing_files (FFEBAD_severityFATAL); + ffebad_start_msg ("At %0, INCLUDE nesting too deep", + FFEBAD_severityFATAL); + ffebad_string (fname); + ffebad_here (0, l, c); + ffebad_finish (); + return NULL; + } + + instack[indepth].line = ffewhere_line_use (l); + instack[indepth].column = ffewhere_column_use (c); + + fp = &instack[indepth + 1]; + bzero ((char *) fp, sizeof (FILE_BUF)); + fp->nominal_fname = fp->fname = fname; + fp->dir = searchptr; + + indepth++; + input_file_stack_tick++; + + return f; +} +#endif /* FFECOM_GCC_INCLUDE */ diff --git a/gcc/f/com.h b/gcc/f/com.h new file mode 100644 index 000000000000..477e0860f405 --- /dev/null +++ b/gcc/f/com.h @@ -0,0 +1,419 @@ +/* com.h -- Public #include File (module.h template V1.0) + Copyright (C) 1995-1997 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + com.c + + Modifications: +*/ + +/* Allow multiple inclusion to work. */ + +#ifndef _H_f_com +#define _H_f_com + +/* Simple definitions and enumerations. */ + +#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_globalNULL NULL_TREE +#define FFECOM_labelNULL NULL_TREE +#define FFECOM_storageNULL NULL_TREE +#define FFECOM_symbolNULL ffecom_symbol_null_ + +/* Shorthand for types used in f2c.h and that g77 perhaps allows some + flexibility regarding in the section below. I.e. the actual numbers + below aren't important, as long as they're unique. */ + +#define FFECOM_f2ccodeCHAR 1 +#define FFECOM_f2ccodeSHORT 2 +#define FFECOM_f2ccodeINT 3 +#define FFECOM_f2ccodeLONG 4 +#define FFECOM_f2ccodeLONGLONG 5 +#define FFECOM_f2ccodeCHARPTR 6 /* char * */ +#define FFECOM_f2ccodeFLOAT 7 +#define FFECOM_f2ccodeDOUBLE 8 +#define FFECOM_f2ccodeLONGDOUBLE 9 +#define FFECOM_f2ccodeTWOREALS 10 +#define FFECOM_f2ccodeTWODOUBLEREALS 11 + +#if FFECOM_DETERMINE_TYPES /* only for com.c and configure */ + +/* Begin f2c.h information. This must match the info in the f2c.h used + to build the libf2c with which g77-generated code is linked, or there + will probably be bugs, some of them difficult to detect or even trigger. */ + +#include "config.j" + +/* Do we need int (for 32-bit or 64-bit systems) or long (16-bit or + normally 32-bit) for f2c-type integers? */ + +#ifndef BITS_PER_WORD +#define BITS_PER_WORD 32 +#endif + +#ifndef CHAR_TYPE_SIZE +#define CHAR_TYPE_SIZE BITS_PER_UNIT +#endif + +#ifndef SHORT_TYPE_SIZE +#define SHORT_TYPE_SIZE (BITS_PER_UNIT * MIN ((UNITS_PER_WORD + 1) / 2, 2)) +#endif + +#ifndef INT_TYPE_SIZE +#define INT_TYPE_SIZE BITS_PER_WORD +#endif + +#ifndef LONG_TYPE_SIZE +#define LONG_TYPE_SIZE BITS_PER_WORD +#endif + +#ifndef LONG_LONG_TYPE_SIZE +#define LONG_LONG_TYPE_SIZE (BITS_PER_WORD * 2) +#endif + +#ifndef WCHAR_UNSIGNED +#define WCHAR_UNSIGNED 0 +#endif + +#ifndef FLOAT_TYPE_SIZE +#define FLOAT_TYPE_SIZE BITS_PER_WORD +#endif + +#ifndef DOUBLE_TYPE_SIZE +#define DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2) +#endif + +#ifndef LONG_DOUBLE_TYPE_SIZE +#define LONG_DOUBLE_TYPE_SIZE (BITS_PER_WORD * 2) +#endif + +#if LONG_TYPE_SIZE == FLOAT_TYPE_SIZE +# define FFECOM_f2cINTEGER FFECOM_f2ccodeLONG +# define FFECOM_f2cLOGICAL FFECOM_f2ccodeLONG +#elif INT_TYPE_SIZE == FLOAT_TYPE_SIZE +# define FFECOM_f2cINTEGER FFECOM_f2ccodeINT +# define FFECOM_f2cLOGICAL FFECOM_f2ccodeINT +#else +# error Cannot find a suitable type for FFECOM_f2cINTEGER +#endif + +#if LONG_TYPE_SIZE == (FLOAT_TYPE_SIZE * 2) +# define FFECOM_f2cLONGINT FFECOM_f2ccodeLONG +#elif LONG_LONG_TYPE_SIZE == (FLOAT_TYPE_SIZE * 2) +# define FFECOM_f2cLONGINT FFECOM_f2ccodeLONGLONG +#else +# error Cannot find a suitable type for FFECOM_f2cLONGINT +#endif + +#define FFECOM_f2cADDRESS FFECOM_f2ccodeCHARPTR +#define FFECOM_f2cSHORTINT FFECOM_f2ccodeSHORT +#define FFECOM_f2cREAL FFECOM_f2ccodeFLOAT +#define FFECOM_f2cDOUBLEREAL FFECOM_f2ccodeDOUBLE +#define FFECOM_f2cCOMPLEX FFECOM_f2ccodeTWOREALS +#define FFECOM_f2cDOUBLECOMPLEX FFECOM_f2ccodeTWODOUBLEREALS +#define FFECOM_f2cSHORTLOGICAL FFECOM_f2ccodeSHORT +#define FFECOM_f2cLOGICAL1 FFECOM_f2ccodeCHAR +#define FFECOM_f2cINTEGER1 FFECOM_f2ccodeCHAR + +/* These must be f2c's INTEGER type, to match runtime/f2c.h.in. */ + +#define FFECOM_f2cFLAG FFECOM_f2cINTEGER +#define FFECOM_f2cFTNINT FFECOM_f2cINTEGER +#define FFECOM_f2cFTNLEN FFECOM_f2cINTEGER + +#endif /* #if FFECOM_DETERMINE_TYPES */ + +/* Everything else in f2c.h, specifically the structures used in + interfacing compiled code with the library, must remain exactly + as delivered, or g77 internals (mostly com.c and ste.c) must + be modified accordingly to compensate. Or there will be...trouble. */ + +typedef enum + { +#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) CODE, +#include "com-rt.def" +#undef DEFGFRT + FFECOM_gfrt + } ffecomGfrt; + +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + +/* Typedefs. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +#ifndef TREE_CODE +#include "tree.j" +#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 ffecomLabel; +#define FFECOM_globalHOOK +typedef tree ffecomGlobal; +#define FFECOM_labelHOOK +typedef tree ffecomStorage; +#define FFECOM_storageHOOK +typedef struct _ffecom_symbol_ ffecomSymbol; +#define FFECOM_symbolHOOK + +struct _ffecom_symbol_ + { + tree decl_tree; + tree length_tree; /* For CHARACTER dummies. */ + tree vardesc_tree; /* For NAMELIST. */ + 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. */ + +#include "bld.h" +#include "info.h" +#include "lab.h" +#include "storag.h" +#include "symbol.h" + +/* Structure definitions. */ + + +/* Global objects accessed by users of this module. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +extern tree long_integer_type_node; +extern tree complex_double_type_node; +extern tree string_type_node; +extern tree ffecom_integer_type_node; +extern tree ffecom_integer_zero_node; +extern tree ffecom_integer_one_node; +extern tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype]; +extern ffecomSymbol ffecom_symbol_null_; +extern ffeinfoKindtype ffecom_pointer_kind_; +extern ffeinfoKindtype ffecom_label_kind_; + +extern int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype]; +extern tree ffecom_f2c_integer_type_node; +extern tree ffecom_f2c_address_type_node; +extern tree ffecom_f2c_real_type_node; +extern tree ffecom_f2c_doublereal_type_node; +extern tree ffecom_f2c_complex_type_node; +extern tree ffecom_f2c_doublecomplex_type_node; +extern tree ffecom_f2c_longint_type_node; +extern tree ffecom_f2c_logical_type_node; +extern tree ffecom_f2c_flag_type_node; +extern tree ffecom_f2c_ftnlen_type_node; +extern tree ffecom_f2c_ftnlen_zero_node; +extern tree ffecom_f2c_ftnlen_one_node; +extern tree ffecom_f2c_ftnlen_two_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); +bool ffecom_2pass_advise_entrypoint (ffesymbol entry); +void ffecom_2pass_do_entrypoint (ffesymbol entry); +tree ffecom_2s (enum tree_code code, tree type, tree node1, tree node2); +tree ffecom_3 (enum tree_code code, tree type, tree node1, tree node2, + tree node3); +tree ffecom_3s (enum tree_code code, tree type, tree node1, tree node2, + tree node3); +tree ffecom_arg_expr (ffebld expr, tree *length); +tree ffecom_arg_ptr_to_expr (ffebld expr, tree *length); +tree ffecom_call_gfrt (ffecomGfrt ix, tree args); +tree ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt, + ffeinfoKindtype kt, tree tree_type); +tree ffecom_decl_field (tree context, tree prevfield, char *name, + tree type); +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ +void ffecom_close_include (FILE *f); +int ffecom_decode_include_option (char *spec); +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); +tree ffecom_expr_rw (ffebld expr); +void ffecom_finish_compile (void); +void ffecom_finish_decl (tree decl, tree init, bool is_top_level); +void ffecom_finish_progunit (void); +tree ffecom_get_invented_identifier (char *pattern, char *text, + int number); +ffeinfoKindtype ffecom_gfrt_basictype (ffecomGfrt ix); +ffeinfoKindtype ffecom_gfrt_kindtype (ffecomGfrt ix); +void ffecom_init_0 (void); +void ffecom_init_2 (void); +tree ffecom_list_expr (ffebld list); +tree ffecom_list_ptr_to_expr (ffebld list); +tree ffecom_lookup_label (ffelab label); +tree ffecom_modify (tree newtype, tree lhs, tree rhs); +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ +void ffecom_file (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_pop_calltemps (void); +void ffecom_pop_tempvar (tree var); +tree ffecom_ptr_to_expr (ffebld expr); +void ffecom_push_calltemps (void); +tree ffecom_push_tempvar (tree type, ffetargetCharacterSize size, + int elements, bool auto_pop); +tree ffecom_return_expr (ffebld expr); +tree ffecom_save_tree (tree t); +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_which_entrypoint_decl (void); +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + +/* ~~~Eliminate these when possible, since the back end should be + declaring them in some .h file. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +extern int flag_pedantic_errors; +void emit_nop (void); +void announce_function (tree decl); +extern FILE *asm_out_file; +void assemble_variable (tree decl, int top_level, int at_end, + int dont_output_data); +void assemble_zeros (int size); +int count_error (int warningp); +void error (char *s, ...); +void expand_decl (tree decl); +void expand_computed_goto (tree exp); +void expand_function_end (char *filename, int line, int end_bindings); +void expand_function_start (tree subr, int parms_have_cleanups); +void expand_main_function (void); +void fatal (char *s, ...); +void init_function_start (tree subr, char *filename, int line); +void make_function_rtl (tree decl); +void make_decl_rtl (tree decl, char *asmspec, int top_level); +void make_var_volatile (tree var); +int mark_addressable (tree expr); +void output_inline_function (tree fndecl); +void pedwarn (char *s, ...); +void pop_function_context (void); +void pop_momentary_nofree (void); +void preserve_initializer (void); +void print_node (FILE *file, char *prefix, tree node, int indent); +void push_function_context (void); +void push_obstacks (struct obstack *current, struct obstack *saveable); +void put_var_into_stack (tree decl); +void remember_end_note (tree block); +void report_error_function (char *file); +void rest_of_compilation (tree decl); +void rest_of_decl_compilation (tree decl, char *asmspec, int top_level, + int at_end); +void resume_temporary_allocation (void); +void set_identifier_size (int size); +void temporary_allocation (void); +tree truthvalue_conversion (tree expr); +void warning_with_decl (tree decl, char *s, ...); +void warning (char *s, ...); +#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_ +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + +#define ffecom_init_1() +#define ffecom_init_3() +#define ffecom_init_4() +#define ffecom_terminate_0() +#define ffecom_terminate_1() +#define ffecom_terminate_2() +#define ffecom_terminate_3() +#define ffecom_terminate_4() + +/* End of #include file. */ + +#endif diff --git a/gcc/f/config-lang.in b/gcc/f/config-lang.in new file mode 100644 index 000000000000..74626241d8c4 --- /dev/null +++ b/gcc/f/config-lang.in @@ -0,0 +1,100 @@ +# Top level configure fragment for GNU FORTRAN. +# Copyright (C) 1995-1997 Free Software Foundation, Inc. + +#This file is part of GNU Fortran. + +#GNU Fortran is free software; you can redistribute it and/or modify +#it under the terms of the GNU General Public License as published by +#the Free Software Foundation; either version 2, or (at your option) +#any later version. + +#GNU Fortran is distributed in the hope that it will be useful, +#but WITHOUT ANY WARRANTY; without even the implied warranty of +#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +#GNU General Public License for more details. + +#You should have received a copy of the GNU General Public License +#along with GNU Fortran; see the file COPYING. If not, write to +#the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +#02111-1307, USA. + +# Configure looks for the existence of this file to auto-config each language. +# We define several parameters used by configure: +# +# language - name of language as it would appear in $(LANGUAGES) +# compilers - value to add to $(COMPILERS) +# stagestuff - files to add to $(STAGESTUFF) +# diff_excludes - files to ignore when building diffs between two versions. + +if grep DECL_STATIC_CONSTRUCTOR $srcdir/tree.h >/dev/null; then + if grep flag_move_all_movables $srcdir/toplev.c >/dev/null; then true + else + echo "You haven't applied the patches to the GCC 2.7.x distribution in" + echo "$srcdir as described in g77/README.g77 and gcc/f/gbe/README." + echo "" + exit 1 + fi +else + if grep put_pending_sizes $srcdir/stor-layout.c >/dev/null; then true + else + echo "You haven't applied the patches to the GCC 2.6.x distribution in" + echo "$srcdir as described in g77/README.g77 and gcc/f/gbe/README." + echo "" + exit 1 + fi +fi + +language="f77" + +compilers="f771\$(exeext)" + +case "$arguments" in +# *--enable-f2c* | *-enable-f2c*) +# echo "f77: enabling f2c." +# stagestuff="g77 g77-cross f771 libf2c.a f2c fc" ;; +# stagestuff="g77 g77-cross f771 libf2c.a f2c" ;; +*) + stagestuff="g77\$(exeext) g77-cross\$(exeext) f771\$(exeext) libf2c.a" ;; +esac + +diff_excludes="-x \"f/g77.info*\"" + +# Create the runtime library directory tree if necessary. +test -d f || mkdir f +test -d f/runtime || mkdir f/runtime +test -d f/runtime/libF77 || mkdir f/runtime/libF77 +test -d f/runtime/libI77 || mkdir f/runtime/libI77 +test -d f/runtime/libU77 || mkdir f/runtime/libU77 + +# Need to make top-level stageN directory trees, else if needed +# later by gcc/Makefile, it'll make only the first levels and +# the language subdirectory levels, not the runtime stuff. +for stageN in stage1 stage2 stage3 stage4 +do + test -d $stageN || mkdir $stageN + test -d $stageN/f || mkdir $stageN/f + test -d $stageN/f/runtime || mkdir $stageN/f/runtime + test -d $stageN/f/runtime/libF77 || mkdir $stageN/f/runtime/libF77 + test -d $stageN/f/runtime/libI77 || mkdir $stageN/f/runtime/libI77 + test -d $stageN/f/runtime/libU77 || mkdir $stageN/f/runtime/libU77 +done + +# Make links into top-level stageN from target trees. +for stageN in stage1 stage2 stage3 stage4 include +do + $remove -f f/$stageN f/runtime/$stageN f/runtime/libF77/$stageN \ + f/runtime/libI77/$stageN f/runtime/libU77/$stageN + (cd f; $symbolic_link ../$stageN . 2>/dev/null) + (cd f/runtime; $symbolic_link ../$stageN . 2>/dev/null) + (cd f/runtime/libF77; $symbolic_link ../$stageN . 2>/dev/null) + (cd f/runtime/libI77; $symbolic_link ../$stageN . 2>/dev/null) + (cd f/runtime/libU77; $symbolic_link ../$stageN . 2>/dev/null) +done + +case "$srcdir" in +.) ;; +*) echo + echo "Building f77 outside the source directory is likely to not work" + echo "unless you are using GNU make or a compatible VPATH mechanism." + echo ;; +esac diff --git a/gcc/f/config.j b/gcc/f/config.j new file mode 100644 index 000000000000..b70c3c07b34f --- /dev/null +++ b/gcc/f/config.j @@ -0,0 +1,27 @@ +/* config.j -- Wrapper for GCC's config.h + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. */ + +#ifndef MAKING_DEPENDENCIES +#ifndef _J_f_config +#define _J_f_config +#include "config.h" +#endif +#endif diff --git a/gcc/f/convert.j b/gcc/f/convert.j new file mode 100644 index 000000000000..c2e1e4f85d9f --- /dev/null +++ b/gcc/f/convert.j @@ -0,0 +1,28 @@ +/* convert.j -- Wrapper for GCC's convert.h + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. */ + +#ifndef MAKING_DEPENDENCIES +#ifndef _J_f_convert +#define _J_f_convert +#include "tree.j" +#include "convert.h" +#endif +#endif diff --git a/gcc/f/data.c b/gcc/f/data.c new file mode 100644 index 000000000000..15bf3b00cbbd --- /dev/null +++ b/gcc/f/data.c @@ -0,0 +1,1810 @@ +/* data.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995, 1996 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + + Description: + Do the tough things for DATA statement (and INTEGER FOO/.../-style + initializations), like implied-DO and suchlike. + + Modifications: +*/ + +/* Include files. */ + +#include "proj.h" +#include "data.h" +#include "bit.h" +#include "bld.h" +#include "com.h" +#include "expr.h" +#include "global.h" +#include "malloc.h" +#include "st.h" +#include "storag.h" +#include "top.h" + +/* Externals defined here. */ + + +/* Simple definitions and enumerations. */ + +/* I picked this value as one that, when plugged into a couple of small + but nearly identical test cases I have called BIG-0.f and BIG-1.f, + causes BIG-1.f to take about 10 times as long (elapsed) to compile + (in f771 only) as BIG-0.f. These test cases differ in that BIG-0.f + doesn't put the one initialized variable in a common area that has + a large uninitialized array in it, while BIG-1.f does. The size of + the array is this many elements, as long as they all are INTEGER + type. Note that, as of 0.5.18, sparse cases are better handled, + so BIG-2.f now is used; it provides nonzero initial + values for all elements of the same array BIG-0 has. */ +#ifndef FFEDATA_sizeTOO_BIG_INIT_ +#define FFEDATA_sizeTOO_BIG_INIT_ 75*1024 +#endif + +/* Internal typedefs. */ + +typedef struct _ffedata_convert_cache_ *ffedataConvertCache_; +typedef struct _ffedata_impdo_ *ffedataImpdo_; + +/* Private include files. */ + + +/* Internal structure definitions. */ + +struct _ffedata_convert_cache_ + { + ffebld converted; /* Results of converting expr to following + type. */ + ffeinfoBasictype basic_type; + ffeinfoKindtype kind_type; + ffetargetCharacterSize size; + ffeinfoRank rank; + }; + +struct _ffedata_impdo_ + { + ffedataImpdo_ outer; /* Enclosing IMPDO construct. */ + ffebld outer_list; /* Item after my IMPDO on the outer list. */ + ffebld my_list; /* Beginning of list in my IMPDO. */ + ffesymbol itervar; /* Iteration variable. */ + ffetargetIntegerDefault increment; + ffetargetIntegerDefault final; + }; + +/* Static objects accessed by functions in this module. */ + +static ffedataImpdo_ ffedata_stack_ = NULL; +static ffebld ffedata_list_ = NULL; +static bool ffedata_reinit_; /* value_ should report REINIT error. */ +static bool ffedata_reported_error_; /* Error has been reported. */ +static ffesymbol ffedata_symbol_ = NULL; /* Symbol being initialized. */ +static ffeinfoBasictype ffedata_basictype_; /* Info on symbol. */ +static ffeinfoKindtype ffedata_kindtype_; +static ffestorag ffedata_storage_; /* If non-NULL, inits go into this parent. */ +static ffeinfoBasictype ffedata_storage_bt_; /* Info on storage. */ +static ffeinfoKindtype ffedata_storage_kt_; +static ffetargetOffset ffedata_storage_size_; /* Size of entire storage. */ +static ffetargetAlign ffedata_storage_units_; /* #units per storage unit. */ +static ffetargetOffset ffedata_arraysize_; /* Size of array being + inited. */ +static ffetargetOffset ffedata_expected_; /* Number of elements to + init. */ +static ffetargetOffset ffedata_number_; /* #elements inited so far. */ +static ffetargetOffset ffedata_offset_; /* Offset of next element. */ +static ffetargetOffset ffedata_symbolsize_; /* Size of entire sym. */ +static ffetargetCharacterSize ffedata_size_; /* Size of an element. */ +static ffetargetCharacterSize ffedata_charexpected_; /* #char to init. */ +static ffetargetCharacterSize ffedata_charnumber_; /* #chars inited. */ +static ffetargetCharacterSize ffedata_charoffset_; /* Offset of next char. */ +static ffedataConvertCache_ ffedata_convert_cache_; /* Fewer conversions. */ +static int ffedata_convert_cache_max_ = 0; /* #entries available. */ +static int ffedata_convert_cache_use_ = 0; /* #entries in use. */ + +/* Static functions (internal). */ + +static bool ffedata_advance_ (void); +static ffebld ffedata_convert_ (ffebld source, ffelexToken source_token, + ffelexToken dest_token, ffeinfoBasictype bt, ffeinfoKindtype kt, + ffeinfoRank rk, ffetargetCharacterSize sz); +static ffetargetInteger1 ffedata_eval_integer1_ (ffebld expr); +static ffetargetOffset ffedata_eval_offset_ (ffebld subscripts, + ffebld dims); +static ffetargetCharacterSize ffedata_eval_substr_begin_ (ffebld expr); +static ffetargetCharacterSize ffedata_eval_substr_end_ (ffebld expr, + ffetargetCharacterSize min, ffetargetCharacterSize max); +static void ffedata_gather_ (ffestorag mst, ffestorag st); +static void ffedata_pop_ (void); +static void ffedata_push_ (void); +static bool ffedata_value_ (ffebld value, ffelexToken token); + +/* Internal macros. */ + + +/* ffedata_begin -- Initialize with list of targets + + ffebld list; + ffedata_begin(list); // ITEM... list of SYMTERs, ARRAYs, SUBSTRs, ... + + Remember the list. After this call, 0...n calls to ffedata_value must + follow, and then a single call to ffedata_end. */ + +void +ffedata_begin (ffebld list) +{ + assert (ffedata_list_ == NULL); + ffedata_list_ = list; + ffedata_symbol_ = NULL; + ffedata_reported_error_ = FALSE; + ffedata_reinit_ = FALSE; + ffedata_advance_ (); +} + +/* ffedata_end -- End of initialization sequence + + if (ffedata_end(FALSE)) + // everything's ok + + Make sure the end of the list is valid here. */ + +bool +ffedata_end (bool reported_error, ffelexToken t) +{ + reported_error |= ffedata_reported_error_; + + /* If still targets to initialize, too few initializers, so complain. */ + + if ((ffedata_symbol_ != NULL) && !reported_error) + { + reported_error = TRUE; + ffebad_start (FFEBAD_DATA_TOOFEW); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_string (ffesymbol_text (ffedata_symbol_)); + ffebad_finish (); + } + + /* Pop off any impdo stacks (present only if ffedata_symbol_ != NULL). */ + + while (ffedata_stack_ != NULL) + ffedata_pop_ (); + + if (ffedata_list_ != NULL) + { + assert (reported_error); + ffedata_list_ = NULL; + } + + return TRUE; +} + +/* ffedata_gather -- Gather previously disparate initializations into one place + + ffestorag st; // A typeCBLOCK or typeLOCAL aggregate. + ffedata_gather(st); + + Prior to this call, st has no init or accretion info, but (presumably + at least one of) its subordinate storage areas has init or accretion + info. After this call, none of the subordinate storage areas has inits, + because they've all been moved into the newly created init/accretion + info for st. During this call, conflicting inits produce only one + error message. */ + +void +ffedata_gather (ffestorag st) +{ + ffesymbol s; + ffebld b; + + /* Prepare info on the storage area we're putting init info into. */ + + ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_, + &ffedata_storage_units_, ffestorag_basictype (st), + ffestorag_kindtype (st)); + ffedata_storage_size_ = ffestorag_size (st) / ffedata_storage_units_; + assert (ffestorag_size (st) % ffedata_storage_units_ == 0); + + /* If a CBLOCK, gather all the init info for its explicit members. */ + + if ((ffestorag_type (st) == FFESTORAG_typeCBLOCK) + && (ffestorag_symbol (st) != NULL)) + { + s = ffestorag_symbol (st); + for (b = ffesymbol_commonlist (s); b != NULL; b = ffebld_trail (b)) + ffedata_gather_ (st, + ffesymbol_storage (ffebld_symter (ffebld_head (b)))); + } + + /* For CBLOCK or LOCAL, gather all the init info for equivalenced members. */ + + ffestorag_drive (ffestorag_list_equivs (st), ffedata_gather_, st); +} + +/* ffedata_value -- Provide some number of initial values + + ffebld value; + ffelexToken t; // Points to the value. + if (ffedata_value(1,value,t)) + // Everything's ok + + Makes sure the value is ok, then remembers it according to the list + provided to ffedata_begin. As many instances of the value may be + supplied as desired, as indicated by the first argument. */ + +bool +ffedata_value (ffetargetIntegerDefault rpt, ffebld value, ffelexToken token) +{ + ffetargetIntegerDefault i; + + /* Maybe ignore zero values, to speed up compiling, even though we lose + checking for multiple initializations for now. */ + + if (!ffe_is_zeros () + && (value != NULL) + && (ffebld_op (value) == FFEBLD_opCONTER) + && ffebld_constant_is_zero (ffebld_conter (value))) + value = NULL; + else if ((value != NULL) + && (ffebld_op (value) == FFEBLD_opANY)) + value = NULL; + else + { + /* Must be a constant. */ + assert (value != NULL); + assert (ffebld_op (value) == FFEBLD_opCONTER); + } + + /* Later we can optimize certain cases by seeing that the target array can + take some number of values, and provide this number to _value_. */ + + if (rpt == 1) + ffedata_convert_cache_use_ = -1; /* Don't bother caching. */ + else + ffedata_convert_cache_use_ = 0; /* Maybe use the cache. */ + + for (i = 0; i < rpt; ++i) + { + if ((ffedata_symbol_ != NULL) + && !ffesymbol_is_init (ffedata_symbol_)) + { + ffesymbol_signal_change (ffedata_symbol_); + ffesymbol_update_init (ffedata_symbol_); + if (1 || ffe_is_90 ()) + ffesymbol_update_save (ffedata_symbol_); +#if FFEGLOBAL_ENABLED + if (ffesymbol_common (ffedata_symbol_) != NULL) + ffeglobal_init_common (ffesymbol_common (ffedata_symbol_), + token); +#endif + ffesymbol_signal_unreported (ffedata_symbol_); + } + if (!ffedata_value_ (value, token)) + return FALSE; + } + + return TRUE; +} + +/* ffedata_advance_ -- Advance initialization target to next item in list + + if (ffedata_advance_()) + // everything's ok + + Sets common info to characterize the next item in the list. Handles + IMPDO constructs accordingly. Does not handle advances within a single + item, as in the common extension "DATA CHARTYPE/33,34,35/", where + CHARTYPE is CHARACTER*3, for example. */ + +static bool +ffedata_advance_ () +{ + ffebld next; + + /* Come here after handling an IMPDO. */ + +tail_recurse: /* :::::::::::::::::::: */ + + /* Assume we're not going to find a new target for now. */ + + ffedata_symbol_ = NULL; + + /* If at the end of the list, we're done. */ + + if (ffedata_list_ == NULL) + { + ffetargetIntegerDefault newval; + + if (ffedata_stack_ == NULL) + return TRUE; /* No IMPDO in progress, we is done! */ + + /* Iterate the IMPDO. */ + + newval = ffesymbol_value (ffedata_stack_->itervar) + + ffedata_stack_->increment; + + /* See if we're still in the loop. */ + + if (((ffedata_stack_->increment > 0) + ? newval > ffedata_stack_->final + : newval < ffedata_stack_->final) + || (((ffesymbol_value (ffedata_stack_->itervar) < 0) + == (ffedata_stack_->increment < 0)) + && ((ffesymbol_value (ffedata_stack_->itervar) < 0) + != (newval < 0)))) /* Overflow/underflow? */ + { /* Done with the loop. */ + ffedata_list_ = ffedata_stack_->outer_list; /* Restore list. */ + ffedata_pop_ (); /* Pop me off the impdo stack. */ + } + else + { /* Still in the loop, reset the list and + update the iter var. */ + ffedata_list_ = ffedata_stack_->my_list; /* Reset list. */ + ffesymbol_set_value (ffedata_stack_->itervar, newval); + } + goto tail_recurse; /* :::::::::::::::::::: */ + } + + /* Move to the next item in the list. */ + + next = ffebld_head (ffedata_list_); + ffedata_list_ = ffebld_trail (ffedata_list_); + + /* Really shouldn't happen. */ + + if (next == NULL) + return TRUE; + + /* See what kind of target this is. */ + + switch (ffebld_op (next)) + { + case FFEBLD_opSYMTER: /* Simple reference to scalar or array. */ + ffedata_symbol_ = ffebld_symter (next); + ffedata_storage_ = (ffesymbol_storage (ffedata_symbol_) == NULL) ? NULL + : ffestorag_parent (ffesymbol_storage (ffedata_symbol_)); + if (ffedata_storage_ != NULL) + { + ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_, + &ffedata_storage_units_, + ffestorag_basictype (ffedata_storage_), + ffestorag_kindtype (ffedata_storage_)); + ffedata_storage_size_ = ffestorag_size (ffedata_storage_) + / ffedata_storage_units_; + assert (ffestorag_size (ffedata_storage_) % ffedata_storage_units_ == 0); + } + + if ((ffesymbol_init (ffedata_symbol_) != NULL) + || (ffesymbol_accretion (ffedata_symbol_) != NULL) + || ((ffedata_storage_ != NULL) + && (ffestorag_init (ffedata_storage_) != NULL))) + { +#if 0 + ffebad_start (FFEBAD_DATA_REINIT); + ffest_ffebad_here_current_stmt (0); + ffebad_string (ffesymbol_text (ffedata_symbol_)); + ffebad_finish (); + ffedata_reported_error_ = TRUE; + return FALSE; +#else + ffedata_reinit_ = TRUE; + return TRUE; +#endif + } + ffedata_basictype_ = ffesymbol_basictype (ffedata_symbol_); + ffedata_kindtype_ = ffesymbol_kindtype (ffedata_symbol_); + if (ffesymbol_rank (ffedata_symbol_) == 0) + ffedata_arraysize_ = 1; + else + { + ffebld size = ffesymbol_arraysize (ffedata_symbol_); + + assert (size != NULL); + assert (ffebld_op (size) == FFEBLD_opCONTER); + assert (ffeinfo_basictype (ffebld_info (size)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (size)) + == FFEINFO_kindtypeINTEGERDEFAULT); + ffedata_arraysize_ = ffebld_constant_integerdefault (ffebld_conter + (size)); + } + ffedata_expected_ = ffedata_arraysize_; + ffedata_number_ = 0; + ffedata_offset_ = 0; + ffedata_size_ = (ffedata_basictype_ == FFEINFO_basictypeCHARACTER) + ? ffesymbol_size (ffedata_symbol_) : 1; + ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_; + ffedata_charexpected_ = ffedata_size_; + ffedata_charnumber_ = 0; + ffedata_charoffset_ = 0; + break; + + case FFEBLD_opARRAYREF: /* Reference to element of array. */ + ffedata_symbol_ = ffebld_symter (ffebld_left (next)); + ffedata_storage_ = (ffesymbol_storage (ffedata_symbol_) == NULL) ? NULL + : ffestorag_parent (ffesymbol_storage (ffedata_symbol_)); + if (ffedata_storage_ != NULL) + { + ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_, + &ffedata_storage_units_, + ffestorag_basictype (ffedata_storage_), + ffestorag_kindtype (ffedata_storage_)); + ffedata_storage_size_ = ffestorag_size (ffedata_storage_) + / ffedata_storage_units_; + assert (ffestorag_size (ffedata_storage_) % ffedata_storage_units_ == 0); + } + + if ((ffesymbol_init (ffedata_symbol_) != NULL) + || ((ffedata_storage_ != NULL) + && (ffestorag_init (ffedata_storage_) != NULL))) + { +#if 0 + ffebad_start (FFEBAD_DATA_REINIT); + ffest_ffebad_here_current_stmt (0); + ffebad_string (ffesymbol_text (ffedata_symbol_)); + ffebad_finish (); + ffedata_reported_error_ = TRUE; + return FALSE; +#else + ffedata_reinit_ = TRUE; + return TRUE; +#endif + } + ffedata_basictype_ = ffesymbol_basictype (ffedata_symbol_); + ffedata_kindtype_ = ffesymbol_kindtype (ffedata_symbol_); + if (ffesymbol_rank (ffedata_symbol_) == 0) + ffedata_arraysize_ = 1; /* Shouldn't happen in this case... */ + else + { + ffebld size = ffesymbol_arraysize (ffedata_symbol_); + + assert (size != NULL); + assert (ffebld_op (size) == FFEBLD_opCONTER); + assert (ffeinfo_basictype (ffebld_info (size)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (size)) + == FFEINFO_kindtypeINTEGERDEFAULT); + ffedata_arraysize_ = ffebld_constant_integerdefault (ffebld_conter + (size)); + } + ffedata_expected_ = 1; + ffedata_number_ = 0; + ffedata_offset_ = ffedata_eval_offset_ (ffebld_right (next), + ffesymbol_dims (ffedata_symbol_)); + ffedata_size_ = (ffedata_basictype_ == FFEINFO_basictypeCHARACTER) + ? ffesymbol_size (ffedata_symbol_) : 1; + ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_; + ffedata_charexpected_ = ffedata_size_; + ffedata_charnumber_ = 0; + ffedata_charoffset_ = 0; + break; + + case FFEBLD_opSUBSTR: /* Substring reference to scalar or array + element. */ + { + bool arrayref = ffebld_op (ffebld_left (next)) == FFEBLD_opARRAYREF; + ffebld colon = ffebld_right (next); + + assert (colon != NULL); + + ffedata_symbol_ = ffebld_symter (ffebld_left (arrayref + ? ffebld_left (next) : next)); + ffedata_storage_ = (ffesymbol_storage (ffedata_symbol_) == NULL) ? NULL + : ffestorag_parent (ffesymbol_storage (ffedata_symbol_)); + if (ffedata_storage_ != NULL) + { + ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_, + &ffedata_storage_units_, + ffestorag_basictype (ffedata_storage_), + ffestorag_kindtype (ffedata_storage_)); + ffedata_storage_size_ = ffestorag_size (ffedata_storage_) + / ffedata_storage_units_; + assert (ffestorag_size (ffedata_storage_) % ffedata_storage_units_ == 0); + } + + if ((ffesymbol_init (ffedata_symbol_) != NULL) + || ((ffedata_storage_ != NULL) + && (ffestorag_init (ffedata_storage_) != NULL))) + { +#if 0 + ffebad_start (FFEBAD_DATA_REINIT); + ffest_ffebad_here_current_stmt (0); + ffebad_string (ffesymbol_text (ffedata_symbol_)); + ffebad_finish (); + ffedata_reported_error_ = TRUE; + return FALSE; +#else + ffedata_reinit_ = TRUE; + return TRUE; +#endif + } + ffedata_basictype_ = ffesymbol_basictype (ffedata_symbol_); + ffedata_kindtype_ = ffesymbol_kindtype (ffedata_symbol_); + if (ffesymbol_rank (ffedata_symbol_) == 0) + ffedata_arraysize_ = 1; + else + { + ffebld size = ffesymbol_arraysize (ffedata_symbol_); + + assert (size != NULL); + assert (ffebld_op (size) == FFEBLD_opCONTER); + assert (ffeinfo_basictype (ffebld_info (size)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (size)) + == FFEINFO_kindtypeINTEGERDEFAULT); + ffedata_arraysize_ = ffebld_constant_integerdefault (ffebld_conter + (size)); + } + ffedata_expected_ = arrayref ? 1 : ffedata_arraysize_; + ffedata_number_ = 0; + ffedata_offset_ = arrayref ? ffedata_eval_offset_ (ffebld_right + (ffebld_left (next)), ffesymbol_dims (ffedata_symbol_)) : 0; + ffedata_size_ = ffesymbol_size (ffedata_symbol_); + ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_; + ffedata_charnumber_ = 0; + ffedata_charoffset_ = ffedata_eval_substr_begin_ (ffebld_head (colon)); + ffedata_charexpected_ = ffedata_eval_substr_end_ (ffebld_head + (ffebld_trail (colon)), ffedata_charoffset_, + ffedata_size_) - ffedata_charoffset_ + 1; + } + break; + + case FFEBLD_opIMPDO: /* Implied-DO construct. */ + { + ffebld itervar; + ffebld start; + ffebld end; + ffebld incr; + ffebld item = ffebld_right (next); + + itervar = ffebld_head (item); + item = ffebld_trail (item); + start = ffebld_head (item); + item = ffebld_trail (item); + end = ffebld_head (item); + item = ffebld_trail (item); + incr = ffebld_head (item); + + ffedata_push_ (); + ffedata_stack_->outer_list = ffedata_list_; + ffedata_stack_->my_list = ffedata_list_ = ffebld_left (next); + + assert (ffeinfo_basictype (ffebld_info (itervar)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (itervar)) + == FFEINFO_kindtypeINTEGERDEFAULT); + ffedata_stack_->itervar = ffebld_symter (itervar); + + assert (ffeinfo_basictype (ffebld_info (start)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (start)) + == FFEINFO_kindtypeINTEGERDEFAULT); + ffesymbol_set_value (ffedata_stack_->itervar, ffedata_eval_integer1_ (start)); + + assert (ffeinfo_basictype (ffebld_info (end)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (end)) + == FFEINFO_kindtypeINTEGERDEFAULT); + ffedata_stack_->final = ffedata_eval_integer1_ (end); + + if (incr == NULL) + ffedata_stack_->increment = 1; + else + { + assert (ffeinfo_basictype (ffebld_info (incr)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (incr)) + == FFEINFO_kindtypeINTEGERDEFAULT); + ffedata_stack_->increment = ffedata_eval_integer1_ (incr); + if (ffedata_stack_->increment == 0) + { + ffebad_start (FFEBAD_DATA_ZERO); + ffest_ffebad_here_current_stmt (0); + ffebad_string (ffesymbol_text (ffedata_stack_->itervar)); + ffebad_finish (); + ffedata_pop_ (); + ffedata_reported_error_ = TRUE; + return FALSE; + } + } + + if ((ffedata_stack_->increment > 0) + ? ffesymbol_value (ffedata_stack_->itervar) + > ffedata_stack_->final + : ffesymbol_value (ffedata_stack_->itervar) + < ffedata_stack_->final) + { + ffedata_reported_error_ = TRUE; + ffebad_start (FFEBAD_DATA_EMPTY); + ffest_ffebad_here_current_stmt (0); + ffebad_string (ffesymbol_text (ffedata_stack_->itervar)); + ffebad_finish (); + ffedata_pop_ (); + return FALSE; + } + } + goto tail_recurse; /* :::::::::::::::::::: */ + + case FFEBLD_opANY: + ffedata_reported_error_ = TRUE; + return FALSE; + + default: + assert ("bad op" == NULL); + break; + } + + return TRUE; +} + +/* ffedata_convert_ -- Convert source expression to given type using cache + + ffebld source; + ffelexToken source_token; + ffelexToken dest_token; // Any appropriate token for "destination". + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffetargetCharactersize sz; + source = ffedata_convert_(source,source_token,dest_token,bt,kt,sz); + + Like ffeexpr_convert, but calls it only if necessary (if the converted + expression doesn't already exist in the cache) and then puts the result + in the cache. */ + +ffebld +ffedata_convert_ (ffebld source, ffelexToken source_token, + ffelexToken dest_token, ffeinfoBasictype bt, + ffeinfoKindtype kt, ffeinfoRank rk, + ffetargetCharacterSize sz) +{ + ffebld converted; + int i; + int max; + ffedataConvertCache_ cache; + + for (i = 0; i < ffedata_convert_cache_use_; ++i) + if ((bt == ffedata_convert_cache_[i].basic_type) + && (kt == ffedata_convert_cache_[i].kind_type) + && (sz == ffedata_convert_cache_[i].size) + && (rk == ffedata_convert_cache_[i].rank)) + return ffedata_convert_cache_[i].converted; + + converted = ffeexpr_convert (source, source_token, dest_token, bt, kt, rk, + sz, FFEEXPR_contextDATA); + + if (ffedata_convert_cache_use_ >= ffedata_convert_cache_max_) + { + if (ffedata_convert_cache_max_ == 0) + max = 4; + else + max = ffedata_convert_cache_max_ << 1; + + if (max > ffedata_convert_cache_max_) + { + cache = (ffedataConvertCache_) malloc_new_ks (malloc_pool_image (), + "FFEDATA cache", max * sizeof (*cache)); + if (ffedata_convert_cache_max_ != 0) + { + memcpy (cache, ffedata_convert_cache_, + ffedata_convert_cache_max_ * sizeof (*cache)); + malloc_kill_ks (malloc_pool_image (), ffedata_convert_cache_, + ffedata_convert_cache_max_ * sizeof (*cache)); + } + ffedata_convert_cache_ = cache; + ffedata_convert_cache_max_ = max; + } + else + return converted; /* In case int overflows! */ + } + + i = ffedata_convert_cache_use_++; + + ffedata_convert_cache_[i].converted = converted; + ffedata_convert_cache_[i].basic_type = bt; + ffedata_convert_cache_[i].kind_type = kt; + ffedata_convert_cache_[i].size = sz; + ffedata_convert_cache_[i].rank = rk; + + return converted; +} + +/* ffedata_eval_integer1_ -- Evaluate expression + + ffetargetIntegerDefault result; + ffebld expr; // must be kindtypeINTEGER1. + + result = ffedata_eval_integer1_(expr); + + Evalues the expression (which yields a kindtypeINTEGER1 result) and + returns the result. */ + +static ffetargetIntegerDefault +ffedata_eval_integer1_ (ffebld expr) +{ + ffetargetInteger1 result; + ffebad error; + + assert (expr != NULL); + + switch (ffebld_op (expr)) + { + case FFEBLD_opCONTER: + return ffebld_constant_integer1 (ffebld_conter (expr)); + + case FFEBLD_opSYMTER: + return ffesymbol_value (ffebld_symter (expr)); + + case FFEBLD_opUPLUS: + return ffedata_eval_integer1_ (ffebld_left (expr)); + + case FFEBLD_opUMINUS: + error = ffetarget_uminus_integer1 (&result, + ffedata_eval_integer1_ (ffebld_left (expr))); + break; + + case FFEBLD_opADD: + error = ffetarget_add_integer1 (&result, + ffedata_eval_integer1_ (ffebld_left (expr)), + ffedata_eval_integer1_ (ffebld_right (expr))); + break; + + case FFEBLD_opSUBTRACT: + error = ffetarget_subtract_integer1 (&result, + ffedata_eval_integer1_ (ffebld_left (expr)), + ffedata_eval_integer1_ (ffebld_right (expr))); + break; + + case FFEBLD_opMULTIPLY: + error = ffetarget_multiply_integer1 (&result, + ffedata_eval_integer1_ (ffebld_left (expr)), + ffedata_eval_integer1_ (ffebld_right (expr))); + break; + + case FFEBLD_opDIVIDE: + error = ffetarget_divide_integer1 (&result, + ffedata_eval_integer1_ (ffebld_left (expr)), + ffedata_eval_integer1_ (ffebld_right (expr))); + break; + + case FFEBLD_opPOWER: + { + ffebld r = ffebld_right (expr); + + if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER) + || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT)) + error = FFEBAD_DATA_EVAL; + else + error = ffetarget_power_integerdefault_integerdefault (&result, + ffedata_eval_integer1_ (ffebld_left (expr)), + ffedata_eval_integer1_ (r)); + } + break; + +#if 0 /* Only for character basictype. */ + case FFEBLD_opCONCATENATE: + error =; + break; +#endif + + case FFEBLD_opNOT: + error = ffetarget_not_integer1 (&result, + ffedata_eval_integer1_ (ffebld_left (expr))); + break; + +#if 0 /* Only for logical basictype. */ + case FFEBLD_opLT: + error =; + break; + + case FFEBLD_opLE: + error =; + break; + + case FFEBLD_opEQ: + error =; + break; + + case FFEBLD_opNE: + error =; + break; + + case FFEBLD_opGT: + error =; + break; + + case FFEBLD_opGE: + error =; + break; +#endif + + case FFEBLD_opAND: + error = ffetarget_and_integer1 (&result, + ffedata_eval_integer1_ (ffebld_left (expr)), + ffedata_eval_integer1_ (ffebld_right (expr))); + break; + + case FFEBLD_opOR: + error = ffetarget_or_integer1 (&result, + ffedata_eval_integer1_ (ffebld_left (expr)), + ffedata_eval_integer1_ (ffebld_right (expr))); + break; + + case FFEBLD_opXOR: + error = ffetarget_xor_integer1 (&result, + ffedata_eval_integer1_ (ffebld_left (expr)), + ffedata_eval_integer1_ (ffebld_right (expr))); + break; + + case FFEBLD_opEQV: + error = ffetarget_eqv_integer1 (&result, + ffedata_eval_integer1_ (ffebld_left (expr)), + ffedata_eval_integer1_ (ffebld_right (expr))); + break; + + case FFEBLD_opNEQV: + error = ffetarget_neqv_integer1 (&result, + ffedata_eval_integer1_ (ffebld_left (expr)), + ffedata_eval_integer1_ (ffebld_right (expr))); + break; + + case FFEBLD_opPAREN: + return ffedata_eval_integer1_ (ffebld_left (expr)); + +#if 0 /* ~~ no idea how to do this */ + case FFEBLD_opPERCENT_LOC: + error =; + break; +#endif + +#if 0 /* not allowed by ANSI, but perhaps as an + extension someday? */ + case FFEBLD_opCONVERT: + switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) + { + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { + default: + error = FFEBAD_DATA_EVAL; + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { + default: + error = FFEBAD_DATA_EVAL; + break; + } + break; + } + break; +#endif + +#if 0 /* not valid ops */ + case FFEBLD_opREPEAT: + error =; + break; + + case FFEBLD_opBOUNDS: + error =; + break; +#endif + +#if 0 /* not allowed by ANSI, but perhaps as an + extension someday? */ + case FFEBLD_opFUNCREF: + error =; + break; +#endif + +#if 0 /* not valid ops */ + case FFEBLD_opSUBRREF: + error =; + break; + + case FFEBLD_opARRAYREF: + error =; + break; +#endif + +#if 0 /* not valid for integer1 */ + case FFEBLD_opSUBSTR: + error =; + break; +#endif + + default: + error = FFEBAD_DATA_EVAL; + break; + } + + if (error != FFEBAD) + { + ffebad_start (error); + ffest_ffebad_here_current_stmt (0); + ffebad_finish (); + result = 0; + } + + return result; +} + +/* ffedata_eval_offset_ -- Evaluate offset info array + + ffetargetOffset offset; // 0...max-1. + ffebld subscripts; // an opITEM list of subscript exprs. + ffebld dims; // an opITEM list of opBOUNDS exprs. + + result = ffedata_eval_offset_(expr); + + Evalues the expression (which yields a kindtypeINTEGER1 result) and + returns the result. */ + +static ffetargetOffset +ffedata_eval_offset_ (ffebld subscripts, ffebld dims) +{ + ffetargetIntegerDefault offset = 0; + ffetargetIntegerDefault width = 1; + ffetargetIntegerDefault value; + ffetargetIntegerDefault lowbound; + ffetargetIntegerDefault highbound; + ffetargetOffset final; + ffebld subscript; + ffebld dim; + ffebld low; + ffebld high; + int rank = 0; + bool ok; + + while (subscripts != NULL) + { + ++rank; + assert (dims != NULL); + + subscript = ffebld_head (subscripts); + dim = ffebld_head (dims); + + assert (ffeinfo_basictype (ffebld_info (subscript)) == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (subscript)) == FFEINFO_kindtypeINTEGER1); + value = ffedata_eval_integer1_ (subscript); + + assert (ffebld_op (dim) == FFEBLD_opBOUNDS); + low = ffebld_left (dim); + high = ffebld_right (dim); + + if (low == NULL) + lowbound = 1; + else + { + assert (ffeinfo_basictype (ffebld_info (low)) == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (low)) == FFEINFO_kindtypeINTEGERDEFAULT); + lowbound = ffedata_eval_integer1_ (low); + } + + assert (ffeinfo_basictype (ffebld_info (high)) == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (high)) == FFEINFO_kindtypeINTEGERDEFAULT); + highbound = ffedata_eval_integer1_ (high); + + if ((value < lowbound) || (value > highbound)) + { + char rankstr[10]; + + sprintf (rankstr, "%d", rank); + value = lowbound; + ffebad_start (FFEBAD_DATA_SUBSCRIPT); + ffebad_string (ffesymbol_text (ffedata_symbol_)); + ffebad_string (rankstr); + ffebad_finish (); + } + + subscripts = ffebld_trail (subscripts); + dims = ffebld_trail (dims); + + offset += width * (value - lowbound); + if (subscripts != NULL) + width *= highbound - lowbound + 1; + } + + assert (dims == NULL); + + ok = ffetarget_offset (&final, offset); + assert (ok); + + return final; +} + +/* ffedata_eval_substr_begin_ -- Evaluate begin-point of substr reference + + ffetargetCharacterSize beginpoint; + ffebld endval; // head(colon). + + beginpoint = ffedata_eval_substr_end_(endval); + + If beginval is NULL, returns 0. Otherwise makes sure beginval is + kindtypeINTEGERDEFAULT, makes sure its value is > 0, + and returns its value minus one, or issues an error message. */ + +static ffetargetCharacterSize +ffedata_eval_substr_begin_ (ffebld expr) +{ + ffetargetIntegerDefault val; + + if (expr == NULL) + return 0; + + assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGERDEFAULT); + + val = ffedata_eval_integer1_ (expr); + + if (val < 1) + { + val = 1; + ffebad_start (FFEBAD_DATA_RANGE); + ffest_ffebad_here_current_stmt (0); + ffebad_string (ffesymbol_text (ffedata_symbol_)); + ffebad_finish (); + ffedata_reported_error_ = TRUE; + } + + return val - 1; +} + +/* ffedata_eval_substr_end_ -- Evaluate end-point of substr reference + + ffetargetCharacterSize endpoint; + ffebld endval; // head(trail(colon)). + ffetargetCharacterSize min; // beginpoint of substr reference. + ffetargetCharacterSize max; // size of entity. + + endpoint = ffedata_eval_substr_end_(endval,dflt); + + If endval is NULL, returns max. Otherwise makes sure endval is + kindtypeINTEGERDEFAULT, makes sure its value is > min and <= max, + and returns its value minus one, or issues an error message. */ + +static ffetargetCharacterSize +ffedata_eval_substr_end_ (ffebld expr, ffetargetCharacterSize min, + ffetargetCharacterSize max) +{ + ffetargetIntegerDefault val; + + if (expr == NULL) + return max - 1; + + assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER1); + + val = ffedata_eval_integer1_ (expr); + + if ((val < (ffetargetIntegerDefault) min) + || (val > (ffetargetIntegerDefault) max)) + { + val = 1; + ffebad_start (FFEBAD_DATA_RANGE); + ffest_ffebad_here_current_stmt (0); + ffebad_string (ffesymbol_text (ffedata_symbol_)); + ffebad_finish (); + ffedata_reported_error_ = TRUE; + } + + return val - 1; +} + +/* ffedata_gather_ -- Gather initial values for sym into master sym inits + + ffestorag mst; // A typeCBLOCK or typeLOCAL aggregate. + ffestorag st; // A typeCOMMON or typeEQUIV member. + ffedata_gather_(mst,st); + + If st has any initialization info, transfer that info into mst and + clear st's info. */ + +void +ffedata_gather_ (ffestorag mst, ffestorag st) +{ + ffesymbol s; + ffesymbol s_whine; /* Symbol to complain about in diagnostics. */ + ffebld b; + ffetargetOffset offset; + ffetargetOffset units_expected; + ffebitCount actual; + ffebldConstantArray array; + ffebld accter; + ffetargetCopyfunc fn; + void *ptr1; + void *ptr2; + size_t size; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffeinfoBasictype ign_bt; + ffeinfoKindtype ign_kt; + ffetargetAlign units; + ffebit bits; + ffetargetOffset source_offset; + bool whine = FALSE; + + if (st == NULL) + return; /* Nothing to do. */ + + s = ffestorag_symbol (st); + + assert (s != NULL); /* Must have a corresponding symbol (else how + inited?). */ + assert (ffestorag_init (st) == NULL); /* No init info on storage itself. */ + assert (ffestorag_accretion (st) == NULL); + + if ((((b = ffesymbol_init (s)) == NULL) + && ((b = ffesymbol_accretion (s)) == NULL)) + || (ffebld_op (b) == FFEBLD_opANY) + || ((ffebld_op (b) == FFEBLD_opCONVERT) + && (ffebld_op (ffebld_left (b)) == FFEBLD_opANY))) + return; /* Nothing to do. */ + + /* b now holds the init/accretion expr. */ + + ffesymbol_set_init (s, NULL); + ffesymbol_set_accretion (s, NULL); + ffesymbol_set_accretes (s, 0); + + s_whine = ffestorag_symbol (mst); + if (s_whine == NULL) + s_whine = s; + + /* Make sure we haven't fully accreted during an array init. */ + + if (ffestorag_init (mst) != NULL) + { + ffebad_start (FFEBAD_DATA_MULTIPLE); + ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ()); + ffebad_string (ffesymbol_text (s_whine)); + ffebad_finish (); + return; + } + + bt = ffeinfo_basictype (ffebld_info (b)); + kt = ffeinfo_kindtype (ffebld_info (b)); + + /* Calculate offset for aggregate area. */ + + ffedata_charexpected_ = (bt == FFEINFO_basictypeCHARACTER) + ? ffebld_size (b) : 1; + ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, bt, + kt);/* Find out unit size of source datum. */ + assert (units % ffedata_storage_units_ == 0); + units_expected = ffedata_charexpected_ * units / ffedata_storage_units_; + offset = (ffestorag_offset (st) - ffestorag_offset (mst)) + / ffedata_storage_units_; + + /* Does an accretion array exist? If not, create it. */ + + if (ffestorag_accretion (mst) == NULL) + { +#if FFEDATA_sizeTOO_BIG_INIT_ != 0 + if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_) + { + char bignum[40]; + + sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_); + ffebad_start (FFEBAD_TOO_BIG_INIT); + ffebad_here (0, ffesymbol_where_line (s_whine), + ffesymbol_where_column (s_whine)); + ffebad_string (ffesymbol_text (s_whine)); + ffebad_string (bignum); + ffebad_finish (); + } +#endif + array = ffebld_constantarray_new (ffedata_storage_bt_, + ffedata_storage_kt_, ffedata_storage_size_); + accter = ffebld_new_accter (array, ffebit_new (ffe_pool_program_unit (), + ffedata_storage_size_)); + ffebld_set_info (accter, ffeinfo_new + (ffedata_storage_bt_, + ffedata_storage_kt_, + 1, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + (ffedata_basictype_ == FFEINFO_basictypeCHARACTER) + ? 1 : FFETARGET_charactersizeNONE)); + ffestorag_set_accretion (mst, accter); + ffestorag_set_accretes (mst, ffedata_storage_size_); + } + else + { + accter = ffestorag_accretion (mst); + assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter)); + array = ffebld_accter (accter); + } + + /* Put value in accretion array at desired offset. */ + + fn = ffetarget_aggregate_ptr_memcpy (ffedata_storage_bt_, ffedata_storage_kt_, + bt, kt); + + switch (ffebld_op (b)) + { + case FFEBLD_opCONTER: + ffebld_constantarray_prepare (&ptr1, &ptr2, &size, array, ffedata_storage_bt_, + ffedata_storage_kt_, offset, + ffebld_constant_ptr_to_union (ffebld_conter (b)), + bt, kt); + (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like + operation. */ + ffebit_count (ffebld_accter_bits (accter), + offset, FALSE, units_expected, &actual); /* How many FALSE? */ + if (units_expected != (ffetargetOffset) actual) + { + ffebad_start (FFEBAD_DATA_MULTIPLE); + ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ()); + ffebad_string (ffesymbol_text (s)); + ffebad_finish (); + } + ffestorag_set_accretes (mst, + ffestorag_accretes (mst) + - actual); /* Decrement # of values + actually accreted. */ + ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected); + + /* If done accreting for this storage area, establish as initialized. */ + + if (ffestorag_accretes (mst) == 0) + { + ffestorag_set_init (mst, accter); + ffestorag_set_accretion (mst, NULL); + ffebit_kill (ffebld_accter_bits (ffestorag_init (mst))); + ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER); + ffebld_set_arrter (ffestorag_init (mst), + ffebld_accter (ffestorag_init (mst))); + ffebld_arrter_set_size (ffestorag_init (mst), + ffedata_storage_size_); + ffecom_notify_init_storage (mst); + } + + return; + + case FFEBLD_opARRTER: + ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_, + ffedata_storage_kt_, offset, ffebld_arrter (b), + bt, kt); + size *= ffebld_arrter_size (b); + units_expected *= ffebld_arrter_size (b); + (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like + operation. */ + ffebit_count (ffebld_accter_bits (accter), + offset, FALSE, units_expected, &actual); /* How many FALSE? */ + if (units_expected != (ffetargetOffset) actual) + { + ffebad_start (FFEBAD_DATA_MULTIPLE); + ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ()); + ffebad_string (ffesymbol_text (s)); + ffebad_finish (); + } + ffestorag_set_accretes (mst, + ffestorag_accretes (mst) + - actual); /* Decrement # of values + actually accreted. */ + ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected); + + /* If done accreting for this storage area, establish as initialized. */ + + if (ffestorag_accretes (mst) == 0) + { + ffestorag_set_init (mst, accter); + ffestorag_set_accretion (mst, NULL); + ffebit_kill (ffebld_accter_bits (ffestorag_init (mst))); + ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER); + ffebld_set_arrter (ffestorag_init (mst), + ffebld_accter (ffestorag_init (mst))); + ffebld_arrter_set_size (ffestorag_init (mst), + ffedata_storage_size_); + ffecom_notify_init_storage (mst); + } + + return; + + case FFEBLD_opACCTER: + ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_, + ffedata_storage_kt_, offset, ffebld_accter (b), + bt, kt); + bits = ffebld_accter_bits (b); + source_offset = 0; + + for (;;) + { + ffetargetOffset unexp; + ffetargetOffset siz; + ffebitCount length; + bool value; + + ffebit_test (bits, source_offset, &value, &length); + if (length == 0) + break; /* Exit the loop early. */ + siz = size * length; + unexp = units_expected * length; + if (value) + { + (*fn) (ptr1, ptr2, siz); /* Does memcpy-like operation. */ + ffebit_count (ffebld_accter_bits (accter), /* How many FALSE? */ + offset, FALSE, unexp, &actual); + if (!whine && (unexp != (ffetargetOffset) actual)) + { + whine = TRUE; /* Don't whine more than once for one gather. */ + ffebad_start (FFEBAD_DATA_MULTIPLE); + ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ()); + ffebad_string (ffesymbol_text (s)); + ffebad_finish (); + } + ffestorag_set_accretes (mst, + ffestorag_accretes (mst) + - actual); /* Decrement # of values + actually accreted. */ + ffebit_set (ffebld_accter_bits (accter), offset, 1, unexp); + } + source_offset += length; + offset += unexp; + ptr1 = ((char *) ptr1) + siz; + ptr2 = ((char *) ptr2) + siz; + } + + /* If done accreting for this storage area, establish as initialized. */ + + if (ffestorag_accretes (mst) == 0) + { + ffestorag_set_init (mst, accter); + ffestorag_set_accretion (mst, NULL); + ffebit_kill (ffebld_accter_bits (ffestorag_init (mst))); + ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER); + ffebld_set_arrter (ffestorag_init (mst), + ffebld_accter (ffestorag_init (mst))); + ffebld_arrter_set_size (ffestorag_init (mst), + ffedata_storage_size_); + ffecom_notify_init_storage (mst); + } + + return; + + default: + assert ("bad init op in gather_" == NULL); + return; + } +} + +/* ffedata_pop_ -- Pop an impdo stack entry + + ffedata_pop_(); */ + +static void +ffedata_pop_ () +{ + ffedataImpdo_ victim = ffedata_stack_; + + assert (victim != NULL); + + ffedata_stack_ = ffedata_stack_->outer; + + malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim)); +} + +/* ffedata_push_ -- Push an impdo stack entry + + ffedata_push_(); */ + +static void +ffedata_push_ () +{ + ffedataImpdo_ baby; + + baby = malloc_new_ks (ffe_pool_program_unit (), "ffedataImpdo_", sizeof (*baby)); + + baby->outer = ffedata_stack_; + ffedata_stack_ = baby; +} + +/* ffedata_value_ -- Provide an initial value + + ffebld value; + ffelexToken t; // Points to the value. + if (ffedata_value(value,t)) + // Everything's ok + + Makes sure the value is ok, then remembers it according to the list + provided to ffedata_begin. */ + +static bool +ffedata_value_ (ffebld value, ffelexToken token) +{ + + /* If already reported an error, don't do anything. */ + + if (ffedata_reported_error_) + return FALSE; + + /* If the value is an error marker, remember we've seen one and do nothing + else. */ + + if ((value != NULL) + && (ffebld_op (value) == FFEBLD_opANY)) + { + ffedata_reported_error_ = TRUE; + return FALSE; + } + + /* If too many values (no more targets), complain. */ + + if (ffedata_symbol_ == NULL) + { + ffebad_start (FFEBAD_DATA_TOOMANY); + ffebad_here (0, ffelex_token_where_line (token), + ffelex_token_where_column (token)); + ffebad_finish (); + ffedata_reported_error_ = TRUE; + return FALSE; + } + + /* If ffedata_advance_ wanted to register a complaint, do it now + that we have the token to point at instead of just the start + of the whole statement. */ + + if (ffedata_reinit_) + { + ffebad_start (FFEBAD_DATA_REINIT); + ffebad_here (0, ffelex_token_where_line (token), + ffelex_token_where_column (token)); + ffebad_string (ffesymbol_text (ffedata_symbol_)); + ffebad_finish (); + ffedata_reported_error_ = TRUE; + return FALSE; + } + +#if FFEGLOBAL_ENABLED + if (ffesymbol_common (ffedata_symbol_) != NULL) + ffeglobal_init_common (ffesymbol_common (ffedata_symbol_), token); +#endif + + /* Convert value to desired type. */ + + if (value != NULL) + { + if (ffedata_convert_cache_use_ == -1) + value = ffeexpr_convert + (value, token, NULL, ffedata_basictype_, + ffedata_kindtype_, 0, + (ffedata_basictype_ == FFEINFO_basictypeCHARACTER) + ? ffedata_charexpected_ : FFETARGET_charactersizeNONE, + FFEEXPR_contextDATA); + else /* Use the cache. */ + value = ffedata_convert_ + (value, token, NULL, ffedata_basictype_, + ffedata_kindtype_, 0, + (ffedata_basictype_ == FFEINFO_basictypeCHARACTER) + ? ffedata_charexpected_ : FFETARGET_charactersizeNONE); + } + + /* If we couldn't, bug out. */ + + if ((value != NULL) && (ffebld_op (value) == FFEBLD_opANY)) + { + ffedata_reported_error_ = TRUE; + return FALSE; + } + + /* Handle the case where initializes go to a parent's storage area. */ + + if (ffedata_storage_ != NULL) + { + ffetargetOffset offset; + ffetargetOffset units_expected; + ffebitCount actual; + ffebldConstantArray array; + ffebld accter; + ffetargetCopyfunc fn; + void *ptr1; + void *ptr2; + size_t size; + ffeinfoBasictype ign_bt; + ffeinfoKindtype ign_kt; + ffetargetAlign units; + + /* Make sure we haven't fully accreted during an array init. */ + + if (ffestorag_init (ffedata_storage_) != NULL) + { + ffebad_start (FFEBAD_DATA_MULTIPLE); + ffebad_here (0, ffelex_token_where_line (token), + ffelex_token_where_column (token)); + ffebad_string (ffesymbol_text (ffedata_symbol_)); + ffebad_finish (); + ffedata_reported_error_ = TRUE; + return FALSE; + } + + /* Calculate offset. */ + + offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_; + + /* Is offset within range? If not, whine, but don't do anything else. */ + + if (offset + ffedata_charexpected_ - 1 > ffedata_symbolsize_) + { + ffebad_start (FFEBAD_DATA_RANGE); + ffest_ffebad_here_current_stmt (0); + ffebad_string (ffesymbol_text (ffedata_symbol_)); + ffebad_finish (); + ffedata_reported_error_ = TRUE; + return FALSE; + } + + /* Now calculate offset for aggregate area. */ + + ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, ffedata_basictype_, + ffedata_kindtype_); /* Find out unit size of + source datum. */ + assert (units % ffedata_storage_units_ == 0); + units_expected = ffedata_charexpected_ * units / ffedata_storage_units_; + offset *= units / ffedata_storage_units_; + offset += (ffestorag_offset (ffesymbol_storage (ffedata_symbol_)) + - ffestorag_offset (ffedata_storage_)) + / ffedata_storage_units_; + + assert (offset + units_expected - 1 <= ffedata_storage_size_); + + /* Does an accretion array exist? If not, create it. */ + + if (value != NULL) + { + if (ffestorag_accretion (ffedata_storage_) == NULL) + { +#if FFEDATA_sizeTOO_BIG_INIT_ != 0 + if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_) + { + char bignum[40]; + + sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_); + ffebad_start (FFEBAD_TOO_BIG_INIT); + ffebad_here (0, ffelex_token_where_line (token), + ffelex_token_where_column (token)); + ffebad_string (ffesymbol_text (ffedata_symbol_)); + ffebad_string (bignum); + ffebad_finish (); + } +#endif + array = ffebld_constantarray_new + (ffedata_storage_bt_, ffedata_storage_kt_, + ffedata_storage_size_); + accter = ffebld_new_accter (array, + ffebit_new (ffe_pool_program_unit (), + ffedata_storage_size_)); + ffebld_set_info (accter, ffeinfo_new + (ffedata_storage_bt_, + ffedata_storage_kt_, + 1, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + (ffedata_basictype_ + == FFEINFO_basictypeCHARACTER) + ? 1 : FFETARGET_charactersizeNONE)); + ffestorag_set_accretion (ffedata_storage_, accter); + ffestorag_set_accretes (ffedata_storage_, ffedata_storage_size_); + } + else + { + accter = ffestorag_accretion (ffedata_storage_); + assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter)); + array = ffebld_accter (accter); + } + + /* Put value in accretion array at desired offset. */ + + fn = ffetarget_aggregate_ptr_memcpy + (ffedata_storage_bt_, ffedata_storage_kt_, + ffedata_basictype_, ffedata_kindtype_); + ffebld_constantarray_prepare + (&ptr1, &ptr2, &size, array, ffedata_storage_bt_, + ffedata_storage_kt_, offset, + ffebld_constant_ptr_to_union (ffebld_conter (value)), + ffedata_basictype_, ffedata_kindtype_); + (*fn) (ptr1, ptr2, size); /* Does the appropriate memcpy-like + operation. */ + ffebit_count (ffebld_accter_bits (accter), + offset, FALSE, units_expected, + &actual); /* How many FALSE? */ + if (units_expected != (ffetargetOffset) actual) + { + ffebad_start (FFEBAD_DATA_MULTIPLE); + ffebad_here (0, ffelex_token_where_line (token), + ffelex_token_where_column (token)); + ffebad_string (ffesymbol_text (ffedata_symbol_)); + ffebad_finish (); + } + ffestorag_set_accretes (ffedata_storage_, + ffestorag_accretes (ffedata_storage_) + - actual); /* Decrement # of values + actually accreted. */ + ffebit_set (ffebld_accter_bits (accter), offset, + 1, units_expected); + + /* If done accreting for this storage area, establish as + initialized. */ + + if (ffestorag_accretes (ffedata_storage_) == 0) + { + ffestorag_set_init (ffedata_storage_, accter); + ffestorag_set_accretion (ffedata_storage_, NULL); + ffebit_kill (ffebld_accter_bits + (ffestorag_init (ffedata_storage_))); + ffebld_set_op (ffestorag_init (ffedata_storage_), + FFEBLD_opARRTER); + ffebld_set_arrter + (ffestorag_init (ffedata_storage_), + ffebld_accter (ffestorag_init (ffedata_storage_))); + ffebld_arrter_set_size (ffestorag_init (ffedata_storage_), + ffedata_storage_size_); + ffecom_notify_init_storage (ffedata_storage_); + } + } + + /* If still accreting, adjust specs accordingly and return. */ + + if (++ffedata_number_ < ffedata_expected_) + { + ++ffedata_offset_; + return TRUE; + } + + return ffedata_advance_ (); + } + + /* Figure out where the value goes -- in an accretion array or directly + into the final initial-value slot for the symbol. */ + + if ((ffedata_number_ != 0) + || (ffedata_arraysize_ > 1) + || (ffedata_charnumber_ != 0) + || (ffedata_size_ > ffedata_charexpected_)) + { /* Accrete this value. */ + ffetargetOffset offset; + ffebitCount actual; + ffebldConstantArray array; + ffebld accter = NULL; + + /* Calculate offset. */ + + offset = ffedata_offset_ * ffedata_size_ + ffedata_charoffset_; + + /* Is offset within range? If not, whine, but don't do anything else. */ + + if (offset + ffedata_charexpected_ - 1 > ffedata_symbolsize_) + { + ffebad_start (FFEBAD_DATA_RANGE); + ffest_ffebad_here_current_stmt (0); + ffebad_string (ffesymbol_text (ffedata_symbol_)); + ffebad_finish (); + ffedata_reported_error_ = TRUE; + return FALSE; + } + + /* Does an accretion array exist? If not, create it. */ + + if (value != NULL) + { + if (ffesymbol_accretion (ffedata_symbol_) == NULL) + { +#if FFEDATA_sizeTOO_BIG_INIT_ != 0 + if (ffedata_symbolsize_ >= FFEDATA_sizeTOO_BIG_INIT_ ) + { + char bignum[40]; + + sprintf (&bignum[0], "%ld", (long) ffedata_symbolsize_); + ffebad_start (FFEBAD_TOO_BIG_INIT); + ffebad_here (0, ffelex_token_where_line (token), + ffelex_token_where_column (token)); + ffebad_string (ffesymbol_text (ffedata_symbol_)); + ffebad_string (bignum); + ffebad_finish (); + } +#endif + array = ffebld_constantarray_new + (ffedata_basictype_, ffedata_kindtype_, + ffedata_symbolsize_); + accter = ffebld_new_accter (array, + ffebit_new (ffe_pool_program_unit (), + ffedata_symbolsize_)); + ffebld_set_info (accter, ffeinfo_new + (ffedata_basictype_, + ffedata_kindtype_, + 1, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + (ffedata_basictype_ + == FFEINFO_basictypeCHARACTER) + ? 1 : FFETARGET_charactersizeNONE)); + ffesymbol_set_accretion (ffedata_symbol_, accter); + ffesymbol_set_accretes (ffedata_symbol_, ffedata_symbolsize_); + } + else + { + accter = ffesymbol_accretion (ffedata_symbol_); + assert (ffedata_symbolsize_ + == (ffetargetOffset) ffebld_accter_size (accter)); + array = ffebld_accter (accter); + } + + /* Put value in accretion array at desired offset. */ + + ffebld_constantarray_put + (array, ffedata_basictype_, ffedata_kindtype_, + offset, ffebld_constant_union (ffebld_conter (value))); + ffebit_count (ffebld_accter_bits (accter), offset, FALSE, + ffedata_charexpected_, + &actual); /* How many FALSE? */ + if (actual != (unsigned long int) ffedata_charexpected_) + { + ffebad_start (FFEBAD_DATA_MULTIPLE); + ffebad_here (0, ffelex_token_where_line (token), + ffelex_token_where_column (token)); + ffebad_string (ffesymbol_text (ffedata_symbol_)); + ffebad_finish (); + } + ffesymbol_set_accretes (ffedata_symbol_, + ffesymbol_accretes (ffedata_symbol_) + - actual); /* Decrement # of values + actually accreted. */ + ffebit_set (ffebld_accter_bits (accter), offset, + 1, ffedata_charexpected_); + ffesymbol_signal_unreported (ffedata_symbol_); + } + + /* If still accreting, adjust specs accordingly and return. */ + + if (++ffedata_number_ < ffedata_expected_) + { + ++ffedata_offset_; + return TRUE; + } + + /* Else, if done accreting for this symbol, establish as initialized. */ + + if ((value != NULL) + && (ffesymbol_accretes (ffedata_symbol_) == 0)) + { + ffesymbol_set_init (ffedata_symbol_, accter); + ffesymbol_set_accretion (ffedata_symbol_, NULL); + ffebit_kill (ffebld_accter_bits (ffesymbol_init (ffedata_symbol_))); + ffebld_set_op (ffesymbol_init (ffedata_symbol_), FFEBLD_opARRTER); + ffebld_set_arrter (ffesymbol_init (ffedata_symbol_), + ffebld_accter (ffesymbol_init (ffedata_symbol_))); + ffebld_arrter_set_size (ffesymbol_init (ffedata_symbol_), + ffedata_symbolsize_); + ffecom_notify_init_symbol (ffedata_symbol_); + } + } + else if (value != NULL) + { + /* Simple, direct, one-shot assignment. */ + ffesymbol_set_init (ffedata_symbol_, value); + ffecom_notify_init_symbol (ffedata_symbol_); + } + + /* Call on advance function to get next target in list. */ + + return ffedata_advance_ (); +} diff --git a/gcc/f/data.h b/gcc/f/data.h new file mode 100644 index 000000000000..a17aa2f8b275 --- /dev/null +++ b/gcc/f/data.h @@ -0,0 +1,74 @@ +/* data.h -- Public #include File (module.h template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + data.c + + Modifications: +*/ + +/* Allow multiple inclusion to work. */ + +#ifndef _H_f_data +#define _H_f_data + +/* Simple definitions and enumerations. */ + + +/* Typedefs. */ + + +/* Include files needed by this one. */ + +#include "bld.h" +#include "lex.h" +#include "storag.h" + +/* Structure definitions. */ + + +/* Global objects accessed by users of this module. */ + + +/* Declare functions with prototypes. */ + +void ffedata_begin (ffebld list); +bool ffedata_end (bool report_errors, ffelexToken t); +void ffedata_gather (ffestorag st); +bool ffedata_value (ffetargetIntegerDefault rpt, ffebld value, + ffelexToken value_token); + +/* Define macros. */ + +#define ffedata_init_0() +#define ffedata_init_1() +#define ffedata_init_2() +#define ffedata_init_3() +#define ffedata_init_4() +#define ffedata_terminate_0() +#define ffedata_terminate_1() +#define ffedata_terminate_2() +#define ffedata_terminate_3() +#define ffedata_terminate_4() + +/* End of #include file. */ + +#endif diff --git a/gcc/f/equiv.c b/gcc/f/equiv.c new file mode 100644 index 000000000000..7dd2344cecbe --- /dev/null +++ b/gcc/f/equiv.c @@ -0,0 +1,1444 @@ +/* equiv.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995-1997 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + None + + Description: + Handles the EQUIVALENCE relationships in a program unit. + + Modifications: +*/ + +#define FFEEQUIV_DEBUG 0 + +/* Include files. */ + +#include "proj.h" +#include "equiv.h" +#include "bad.h" +#include "bld.h" +#include "com.h" +#include "data.h" +#include "global.h" +#include "lex.h" +#include "malloc.h" +#include "symbol.h" + +/* Externals defined here. */ + + +/* Simple definitions and enumerations. */ + + +/* Internal typedefs. */ + + +/* Private include files. */ + + +/* Internal structure definitions. */ + +struct _ffeequiv_list_ + { + ffeequiv first; + ffeequiv last; + }; + +/* Static objects accessed by functions in this module. */ + +static struct _ffeequiv_list_ ffeequiv_list_; + +/* Static functions (internal). */ + +static void ffeequiv_destroy_ (ffeequiv eq); +static void ffeequiv_layout_local_ (ffeequiv eq); +static bool ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s, + ffebld expr, bool subtract, + ffetargetOffset adjust, bool no_precede); + +/* Internal macros. */ + + +static void +ffeequiv_destroy_ (ffeequiv victim) +{ + ffebld list; + ffebld item; + ffebld expr; + + for (list = victim->list; list != NULL; list = ffebld_trail (list)) + { + for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item)) + { + ffesymbol sym; + + expr = ffebld_head (item); + sym = ffeequiv_symbol (expr); + if (sym == NULL) + continue; + if (ffesymbol_equiv (sym) != NULL) + ffesymbol_set_equiv (sym, NULL); + } + } + ffeequiv_kill (victim); +} + +/* ffeequiv_layout_local_ -- Lay out storage for local equivalenced vars + + ffeequiv eq; + ffeequiv_layout_local_(eq); + + Makes a single master ffestorag object that contains all the vars + in the equivalence, and makes subordinate ffestorag objects for the + vars with the correct offsets. + + The resulting var offsets are relative not necessarily to 0 -- the + are relative to the offset of the master area, which might be 0 or + negative, but should never be positive. */ + +static void +ffeequiv_layout_local_ (ffeequiv eq) +{ + ffestorag st; /* Equivalence storage area. */ + ffebld list; /* List of list of equivalences. */ + ffebld item; /* List of equivalences. */ + ffebld root_exp; /* Expression for root sym. */ + ffestorag root_st; /* Storage for root. */ + ffesymbol root_sym; /* Root itself. */ + ffebld rooted_exp; /* Expression for rooted sym in an eqlist. */ + ffestorag rooted_st; /* Storage for rooted. */ + ffesymbol rooted_sym; /* Rooted symbol itself. */ + ffetargetOffset eqlist_offset;/* Offset for eqlist from rooted sym. */ + ffetargetAlign alignment; + ffetargetAlign modulo; + ffetargetAlign pad; + ffetargetOffset size; + ffetargetOffset num_elements; + bool new_storage; /* Established new storage info. */ + bool need_storage; /* Have need for more storage info. */ + bool init; + + assert (eq != NULL); + + if (ffeequiv_common (eq) != NULL) + { /* Put in common due to programmer error. */ + ffeequiv_destroy_ (eq); + return; + } + + /* Find the symbol for the first valid item in the list of lists, use that + as the root symbol. Doesn't matter if it won't end up at the beginning + of the list, though. */ + +#if FFEEQUIV_DEBUG + fprintf (stderr, "Equiv1:\n"); +#endif + + root_sym = NULL; + root_exp = NULL; + + for (list = ffeequiv_list (eq); + list != NULL; + list = ffebld_trail (list)) + { /* For every equivalence list in the list of + equivs */ + for (item = ffebld_head (list); + item != NULL; + item = ffebld_trail (item)) + { /* For every equivalence item in the list */ + ffetargetOffset ign; /* Ignored. */ + + root_exp = ffebld_head (item); + root_sym = ffeequiv_symbol (root_exp); + if (root_sym == NULL) + continue; /* Ignore me. */ + + assert (ffesymbol_storage (root_sym) == NULL); /* No storage yet. */ + + if (!ffeequiv_offset_ (&ign, root_sym, root_exp, FALSE, 0, FALSE)) + { + /* We can't just eliminate this one symbol from the list + of candidates, because it might be the only one that + ties all these equivs together. So just destroy the + whole list. */ + + ffeequiv_destroy_ (eq); + return; + } + + break; /* Use first valid eqv expr for root exp/sym. */ + } + if (root_sym != NULL) + break; + } + + if (root_sym == NULL) + { + ffeequiv_destroy_ (eq); + return; + } + + +#if FFEEQUIV_DEBUG + fprintf (stderr, " Root: `%s'\n", ffesymbol_text (root_sym)); +#endif + + /* We've got work to do, so make the LOCAL storage object that'll hold all + the equivalenced vars inside it. */ + + st = ffestorag_new (ffestorag_list_master ()); + ffestorag_set_parent (st, NULL); /* Initializations happen here. */ + ffestorag_set_init (st, NULL); + ffestorag_set_accretion (st, NULL); + ffestorag_set_offset (st, 0); /* Assume equiv will be at root offset 0 for now. */ + ffestorag_set_alignment (st, 1); + ffestorag_set_modulo (st, 0); + ffestorag_set_type (st, FFESTORAG_typeLOCAL); + ffestorag_set_basictype (st, ffesymbol_basictype (root_sym)); + ffestorag_set_kindtype (st, ffesymbol_kindtype (root_sym)); + ffestorag_set_typesymbol (st, root_sym); + ffestorag_set_is_save (st, ffeequiv_is_save (eq)); + if (ffesymbol_is_save (root_sym)) + ffestorag_update_save (st); + ffestorag_set_is_init (st, ffeequiv_is_init (eq)); + if (ffesymbol_is_init (root_sym)) + ffestorag_update_init (st); + ffestorag_set_symbol (st, root_sym); /* Assume this will be the root until + we know better (used only to generate + the internal name for the aggregate area, + e.g. for debugging). */ + + /* Make the EQUIV storage object for the root symbol. */ + + if (ffesymbol_rank (root_sym) == 0) + num_elements = 1; + else + num_elements = ffebld_constant_integerdefault (ffebld_conter + (ffesymbol_arraysize (root_sym))); + ffetarget_layout (ffesymbol_text (root_sym), &alignment, &modulo, &size, + ffesymbol_basictype (root_sym), ffesymbol_kindtype (root_sym), + ffesymbol_size (root_sym), num_elements); + ffestorag_set_size (st, size); /* Set initial size of aggregate area. */ + + pad = ffetarget_align (ffestorag_ptr_to_alignment (st), + ffestorag_ptr_to_modulo (st), 0, alignment, + modulo); + assert (pad == 0); + + root_st = ffestorag_new (ffestorag_list_equivs (st)); + ffestorag_set_parent (root_st, st); /* Initializations happen there. */ + ffestorag_set_init (root_st, NULL); + ffestorag_set_accretion (root_st, NULL); + ffestorag_set_symbol (root_st, root_sym); + ffestorag_set_size (root_st, size); + ffestorag_set_offset (root_st, 0); /* Will not change; always 0 relative to itself! */ + ffestorag_set_alignment (root_st, alignment); + ffestorag_set_modulo (root_st, modulo); + ffestorag_set_type (root_st, FFESTORAG_typeEQUIV); + ffestorag_set_basictype (root_st, ffesymbol_basictype (root_sym)); + ffestorag_set_kindtype (root_st, ffesymbol_kindtype (root_sym)); + ffestorag_set_typesymbol (root_st, root_sym); + ffestorag_set_is_save (root_st, FALSE); /* Assume FALSE, then... */ + if (ffestorag_is_save (st)) /* ...update to TRUE if needed. */ + ffestorag_update_save (root_st); + ffestorag_set_is_init (root_st, FALSE); /* Assume FALSE, then... */ + if (ffestorag_is_init (st)) /* ...update to TRUE if needed. */ + ffestorag_update_init (root_st); + ffesymbol_set_storage (root_sym, root_st); + ffesymbol_signal_unreported (root_sym); + init = ffesymbol_is_init (root_sym); + + /* Now that we know the root (offset=0) symbol, revisit all the lists and + do the actual storage allocation. Keep doing this until we've gone + through them all without making any new storage objects. */ + + do + { + new_storage = FALSE; + need_storage = FALSE; + for (list = ffeequiv_list (eq); + list != NULL; + list = ffebld_trail (list)) + { /* For every equivalence list in the list of + equivs */ + /* Now find a "rooted" symbol in this list. That is, find the + first item we can that is valid and whose symbol already + has a storage area, because that means we know where it + belongs in the equivalence area and can then allocate the + rest of the items in the list accordingly. */ + + rooted_sym = NULL; + rooted_exp = NULL; + eqlist_offset = 0; + + for (item = ffebld_head (list); + item != NULL; + item = ffebld_trail (item)) + { /* For every equivalence item in the list */ + rooted_exp = ffebld_head (item); + rooted_sym = ffeequiv_symbol (rooted_exp); + if ((rooted_sym == NULL) + || ((rooted_st = ffesymbol_storage (rooted_sym)) == NULL)) + { + rooted_sym = NULL; + continue; /* Ignore me. */ + } + + need_storage = TRUE; /* Somebody is likely to need + storage. */ + +#if FFEEQUIV_DEBUG + fprintf (stderr, " Rooted: `%s' at %" ffetargetOffset_f "d\n", + ffesymbol_text (rooted_sym), + ffestorag_offset (rooted_st)); +#endif + + /* The offset of this symbol from the equiv's root symbol + is already known, and the size of this symbol is already + incorporated in the size of the equiv's aggregate area. + What we now determine is the offset of this equivalence + _list_ from the equiv's root symbol. + + For example, if we know that A is at offset 16 from the + root symbol, given EQUIVALENCE (B(24),A(2)), we're looking + at A(2), meaning that the offset for this equivalence list + is 20 (4 bytes beyond the beginning of A, assuming typical + array types, dimensions, and type info). */ + + if (!ffeequiv_offset_ (&eqlist_offset, rooted_sym, rooted_exp, FALSE, + ffestorag_offset (rooted_st), FALSE)) + + { /* Can't use this one. */ + ffesymbol_set_equiv (rooted_sym, NULL);/* Equiv area slated for + death. */ + rooted_sym = NULL; + continue; /* Something's wrong with eqv expr, try another. */ + } + +#if FFEEQUIV_DEBUG + fprintf (stderr, " Eqlist offset: %" ffetargetOffset_f "d\n", + eqlist_offset); +#endif + + break; + } + + /* If no rooted symbol, it means this list has no roots -- yet. + So, forget this list this time around, but we'll get back + to it after the outer loop iterates at least one more time, + and, ultimately, it will have a root. */ + + if (rooted_sym == NULL) + { +#if FFEEQUIV_DEBUG + fprintf (stderr, "No roots.\n"); +#endif + continue; + } + + /* We now have a rooted symbol/expr and the offset of this equivalence + list from the root symbol. The other expressions in this + list all identify an initial storage unit that must have the + same offset. */ + + for (item = ffebld_head (list); + item != NULL; + item = ffebld_trail (item)) + { /* For every equivalence item in the list */ + ffebld item_exp; /* Expression for equivalence. */ + ffestorag item_st; /* Storage for var. */ + ffesymbol item_sym; /* Var itself. */ + ffetargetOffset item_offset; /* Offset for var from root. */ + + item_exp = ffebld_head (item); + item_sym = ffeequiv_symbol (item_exp); + if ((item_sym == NULL) + || (ffesymbol_equiv (item_sym) == NULL)) + continue; /* Ignore me. */ + + if (item_sym == rooted_sym) + continue; /* Rooted sym already set up. */ + + if (!ffeequiv_offset_ (&item_offset, item_sym, item_exp, TRUE, + eqlist_offset, FALSE)) + { + ffesymbol_set_equiv (item_sym, NULL); /* Don't bother with me anymore. */ + continue; + } + +#if FFEEQUIV_DEBUG + fprintf (stderr, " Item `%s' at %" ffetargetOffset_f "d", + ffesymbol_text (item_sym), item_offset); +#endif + + if (ffesymbol_rank (item_sym) == 0) + num_elements = 1; + else + num_elements = ffebld_constant_integerdefault (ffebld_conter + (ffesymbol_arraysize (item_sym))); + ffetarget_layout (ffesymbol_text (item_sym), &alignment, &modulo, + &size, ffesymbol_basictype (item_sym), + ffesymbol_kindtype (item_sym), ffesymbol_size (item_sym), + num_elements); + pad = ffetarget_align (ffestorag_ptr_to_alignment (st), + ffestorag_ptr_to_modulo (st), + item_offset, alignment, modulo); + if (pad != 0) + { + ffebad_start (FFEBAD_EQUIV_ALIGN); + ffebad_string (ffesymbol_text (item_sym)); + ffebad_finish (); + ffesymbol_set_equiv (item_sym, NULL); /* Don't bother with me anymore. */ + continue; + } + + /* If the variable's offset is less than the offset for the + aggregate storage area, it means it has to expand backwards + -- i.e. the new known starting point of the area precedes the + old one. This can't happen with COMMON areas (the standard, + and common sense, disallow it), but it is normal for local + EQUIVALENCE areas. + + Also handle choosing the "documented" rooted symbol for this + area here. It's the symbol at the bottom (lowest offset) + of the aggregate area, with ties going to the name that would + sort to the top of the list of ties. */ + + if (item_offset == ffestorag_offset (st)) + { + if ((item_sym != ffestorag_symbol (st)) + && (strcmp (ffesymbol_text (item_sym), + ffesymbol_text (ffestorag_symbol (st))) + < 0)) + ffestorag_set_symbol (st, item_sym); + } + else if (item_offset < ffestorag_offset (st)) + { + ffetargetOffset new_size; + + /* Increase size of equiv area to start for lower offset relative + to root symbol. */ + + if (!ffetarget_offset_add (&new_size, + ffestorag_offset (st) - item_offset, + ffestorag_size (st))) + ffetarget_offset_overflow (ffesymbol_text (s)); + else + ffestorag_set_size (st, new_size); + + ffestorag_set_symbol (st, item_sym); + ffestorag_set_offset (st, item_offset); + +#if FFEEQUIV_DEBUG + fprintf (stderr, " [eq offset=%" ffetargetOffset_f + "d, size=%" ffetargetOffset_f "d]", + item_offset, new_size); +#endif + } + + if ((item_st = ffesymbol_storage (item_sym)) == NULL) + { /* Create new ffestorag object, extend equiv + area. */ +#if FFEEQUIV_DEBUG + fprintf (stderr, ".\n"); +#endif + new_storage = TRUE; + item_st = ffestorag_new (ffestorag_list_equivs (st)); + ffestorag_set_parent (item_st, st); /* Initializations + happen there. */ + ffestorag_set_init (item_st, NULL); + ffestorag_set_accretion (item_st, NULL); + ffestorag_set_symbol (item_st, item_sym); + ffestorag_set_size (item_st, size); + ffestorag_set_offset (item_st, item_offset); + ffestorag_set_alignment (item_st, alignment); + ffestorag_set_modulo (item_st, modulo); + ffestorag_set_type (item_st, FFESTORAG_typeEQUIV); + ffestorag_set_basictype (item_st, ffesymbol_basictype (item_sym)); + ffestorag_set_kindtype (item_st, ffesymbol_kindtype (item_sym)); + ffestorag_set_typesymbol (item_st, item_sym); + ffestorag_set_is_save (item_st, FALSE); /* Assume FALSE... */ + if (ffestorag_is_save (st)) /* ...update TRUE */ + ffestorag_update_save (item_st); /* if needed. */ + ffestorag_set_is_init (item_st, FALSE); /* Assume FALSE... */ + if (ffestorag_is_init (st)) /* ...update TRUE */ + ffestorag_update_init (item_st); /* if needed. */ + ffesymbol_set_storage (item_sym, item_st); + ffesymbol_signal_unreported (item_sym); + if (ffesymbol_is_init (item_sym)) + init = TRUE; + + /* Determine new size of equiv area, complain if overflow. */ + + if (!ffetarget_offset_add (&size, item_offset, size) + || !ffetarget_offset_add (&size, -ffestorag_offset (st), size)) + ffetarget_offset_overflow (ffesymbol_text (s)); + else if (size > ffestorag_size (st)) + ffestorag_set_size (st, size); + ffestorag_update (st, item_sym, ffesymbol_basictype (item_sym), + ffesymbol_kindtype (item_sym)); + } + else + { +#if FFEEQUIV_DEBUG + fprintf (stderr, " (was %" ffetargetOffset_f "d).\n", + ffestorag_offset (item_st)); +#endif + /* Make sure offset agrees with known offset. */ + if (item_offset != ffestorag_offset (item_st)) + { + char io1[40]; + char io2[40]; + + sprintf (&io1[0], "%" ffetargetOffset_f "d", item_offset); + sprintf (&io2[0], "%" ffetargetOffset_f "d", ffestorag_offset (item_st)); + ffebad_start (FFEBAD_EQUIV_MISMATCH); + ffebad_string (ffesymbol_text (item_sym)); + ffebad_string (ffesymbol_text (root_sym)); + ffebad_string (io1); + ffebad_string (io2); + ffebad_finish (); + } + } + ffesymbol_set_equiv (item_sym, NULL); /* Don't bother with me anymore. */ + } /* (For every equivalence item in the list) */ + ffebld_set_head (list, NULL); /* Don't do this list again. */ + } /* (For every equivalence list in the list of + equivs) */ + } while (new_storage && need_storage); + + ffesymbol_set_equiv (root_sym, NULL); /* This one has storage now. */ + + ffeequiv_kill (eq); /* Fully processed, no longer needed. */ + + if (init) + ffedata_gather (st); /* Gather subordinate inits into one init. */ +} + +/* ffeequiv_offset_ -- Determine offset from start of symbol + + ffetargetOffset offset; + ffesymbol s; // Symbol for error reporting. + ffebld expr; // opSUBSTR, opARRAYREF, opSYMTER, opANY. + bool subtract; // FALSE means add to adjust, TRUE means subtract from it. + ffetargetOffset adjust; // Helps keep answer in pos range (unsigned). + if (!ffeequiv_offset_(&offset,s,expr,subtract,adjust)) + // error doing the calculation, message already printed + + Returns the offset represented by the SUBSTR, ARRAYREF, or SUBSTR/ARRAYREF + combination added-to/subtracted-from the adjustment specified. If there + is an error of some kind, returns FALSE, else returns TRUE. Note that + only the first storage unit specified is considered; A(1:1) and A(1:2000) + have the same first storage unit and so return the same offset. */ + +static bool +ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s UNUSED, + ffebld expr, bool subtract, ffetargetOffset adjust, + bool no_precede) +{ + ffetargetIntegerDefault value = 0; + ffetargetOffset cval; /* Converted value. */ + ffesymbol sym; + + if (expr == NULL) + return FALSE; + +again: /* :::::::::::::::::::: */ + + switch (ffebld_op (expr)) + { + case FFEBLD_opANY: + return FALSE; + + case FFEBLD_opSYMTER: + { + ffetargetOffset size; /* Size of a single unit. */ + ffetargetAlign a; /* Ignored. */ + ffetargetAlign m; /* Ignored. */ + + sym = ffebld_symter (expr); + if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY) + return FALSE; + + ffetarget_layout (ffesymbol_text (sym), &a, &m, &size, + ffesymbol_basictype (sym), + ffesymbol_kindtype (sym), 1, 1); + + if (value < 0) + { /* Really invalid, as in A(-2:5), but in case + it's wanted.... */ + if (!ffetarget_offset (&cval, -value)) + return FALSE; + + if (!ffetarget_offset_multiply (&cval, cval, size)) + return FALSE; + + if (subtract) + return ffetarget_offset_add (offset, cval, adjust); + + if (no_precede && (cval > adjust)) + { + neg: /* :::::::::::::::::::: */ + ffebad_start (FFEBAD_COMMON_NEG); + ffebad_string (ffesymbol_text (sym)); + ffebad_finish (); + return FALSE; + } + return ffetarget_offset_add (offset, -cval, adjust); + } + + if (!ffetarget_offset (&cval, value)) + return FALSE; + + if (!ffetarget_offset_multiply (&cval, cval, size)) + return FALSE; + + if (!subtract) + return ffetarget_offset_add (offset, cval, adjust); + + if (no_precede && (cval > adjust)) + goto neg; /* :::::::::::::::::::: */ + + return ffetarget_offset_add (offset, -cval, adjust); + } + + case FFEBLD_opARRAYREF: + { + ffebld symexp = ffebld_left (expr); + ffebld subscripts = ffebld_right (expr); + ffebld dims; + ffetargetIntegerDefault width; + ffetargetIntegerDefault arrayval; + ffetargetIntegerDefault lowbound; + ffetargetIntegerDefault highbound; + ffebld subscript; + ffebld dim; + ffebld low; + ffebld high; + int rank = 0; + + if (ffebld_op (symexp) != FFEBLD_opSYMTER) + return FALSE; + + sym = ffebld_symter (symexp); + if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY) + return FALSE; + + if (ffesymbol_size (sym) == FFETARGET_charactersizeNONE) + width = 1; + else + width = ffesymbol_size (sym); + dims = ffesymbol_dims (sym); + + while (subscripts != NULL) + { + ++rank; + if (dims == NULL) + { + ffebad_start (FFEBAD_EQUIV_MANY); + ffebad_string (ffesymbol_text (sym)); + ffebad_finish (); + return FALSE; + } + + subscript = ffebld_head (subscripts); + dim = ffebld_head (dims); + + assert (ffebld_op (subscript) == FFEBLD_opCONTER); + assert (ffeinfo_basictype (ffebld_info (subscript)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (subscript)) + == FFEINFO_kindtypeINTEGERDEFAULT); + arrayval = ffebld_constant_integerdefault (ffebld_conter + (subscript)); + + assert (ffebld_op (dim) == FFEBLD_opBOUNDS); + low = ffebld_left (dim); + high = ffebld_right (dim); + + if (low == NULL) + lowbound = 1; + else + { + assert (ffeinfo_basictype (ffebld_info (low)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (low)) + == FFEINFO_kindtypeINTEGERDEFAULT); + lowbound + = ffebld_constant_integerdefault (ffebld_conter (low)); + } + + assert (ffebld_op (high) == FFEBLD_opCONTER); + assert (ffeinfo_basictype (ffebld_info (high)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (high)) + == FFEINFO_kindtypeINTEGER1); + highbound + = ffebld_constant_integerdefault (ffebld_conter (high)); + + if ((arrayval < lowbound) || (arrayval > highbound)) + { + char rankstr[10]; + + sprintf (rankstr, "%d", rank); + ffebad_start (FFEBAD_EQUIV_SUBSCRIPT); + ffebad_string (ffesymbol_text (sym)); + ffebad_string (rankstr); + ffebad_finish (); + } + + subscripts = ffebld_trail (subscripts); + dims = ffebld_trail (dims); + + value += width * (arrayval - lowbound); + if (subscripts != NULL) + width *= highbound - lowbound + 1; + } + + if (dims != NULL) + { + ffebad_start (FFEBAD_EQUIV_FEW); + ffebad_string (ffesymbol_text (sym)); + ffebad_finish (); + return FALSE; + } + + expr = symexp; + } + goto again; /* :::::::::::::::::::: */ + + case FFEBLD_opSUBSTR: + { + ffebld begin = ffebld_head (ffebld_right (expr)); + + expr = ffebld_left (expr); + if (ffebld_op (expr) == FFEBLD_opARRAYREF) + sym = ffebld_symter (ffebld_left (expr)); + else if (ffebld_op (expr) == FFEBLD_opSYMTER) + sym = ffebld_symter (expr); + else + sym = NULL; + + if ((sym != NULL) + && (ffesymbol_basictype (sym) == FFEINFO_basictypeANY)) + return FALSE; + + if (begin == NULL) + value = 0; + else + { + assert (ffebld_op (begin) == FFEBLD_opCONTER); + assert (ffeinfo_basictype (ffebld_info (begin)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (begin)) + == FFEINFO_kindtypeINTEGERDEFAULT); + + value = ffebld_constant_integerdefault (ffebld_conter (begin)); + + if ((value < 1) + || ((sym != NULL) + && (value > ffesymbol_size (sym)))) + { + ffebad_start (FFEBAD_EQUIV_RANGE); + ffebad_string (ffesymbol_text (sym)); + ffebad_finish (); + } + + --value; + } + if ((sym != NULL) + && (ffesymbol_basictype (sym) != FFEINFO_basictypeCHARACTER)) + { + ffebad_start (FFEBAD_EQUIV_SUBSTR); + ffebad_string (ffesymbol_text (sym)); + ffebad_finish (); + value = 0; + } + } + goto again; /* :::::::::::::::::::: */ + + default: + assert ("bad op" == NULL); + return FALSE; + } + +} + +/* ffeequiv_add -- Add list of equivalences to list of lists for eq object + + ffeequiv eq; + ffebld list; + ffelexToken t; // points to first item in equivalence list + ffeequiv_add(eq,list,t); + + Check the list to make sure only one common symbol is involved (even + if multiple times) and agrees with the common symbol for the equivalence + object (or it has no common symbol until now). Prepend (or append, it + doesn't matter) the list to the list of lists for the equivalence object. + Otherwise report an error and return. */ + +void +ffeequiv_add (ffeequiv eq, ffebld list, ffelexToken t) +{ + ffebld item; + ffesymbol symbol; + ffesymbol common = ffeequiv_common (eq); + + for (item = list; item != NULL; item = ffebld_trail (item)) + { + symbol = ffeequiv_symbol (ffebld_head (item)); + + if (ffesymbol_common (symbol) != NULL) /* Is symbol known in COMMON yet? */ + { + if (common == NULL) + common = ffesymbol_common (symbol); + else if (common != ffesymbol_common (symbol)) + { + /* Yes, and symbol disagrees with others on the COMMON area. */ + ffebad_start (FFEBAD_EQUIV_COMMON); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_string (ffesymbol_text (common)); + ffebad_string (ffesymbol_text (ffesymbol_common (symbol))); + ffebad_finish (); + return; + } + } + } + + if ((common != NULL) + && (ffeequiv_common (eq) == NULL)) /* Is COMMON involved already? */ + ffeequiv_set_common (eq, common); /* No, but it is now. */ + + for (item = list; item != NULL; item = ffebld_trail (item)) + { + symbol = ffeequiv_symbol (ffebld_head (item)); + + if (ffesymbol_equiv (symbol) == NULL) + ffesymbol_set_equiv (symbol, eq); + else + assert (ffesymbol_equiv (symbol) == eq); + + if (ffesymbol_common (symbol) == NULL) /* Is symbol in a COMMON + area? */ + { /* No (at least not yet). */ + if (ffesymbol_is_save (symbol)) + ffeequiv_update_save (eq); /* EQUIVALENCE has >=1 SAVEd entity. */ + if (ffesymbol_is_init (symbol)) + ffeequiv_update_init (eq); /* EQUIVALENCE has >=1 init'd entity. */ + continue; /* Nothing more to do here. */ + } + +#if FFEGLOBAL_ENABLED + if (ffesymbol_is_init (symbol)) + ffeglobal_init_common (ffesymbol_common (symbol), t); +#endif + + if (ffesymbol_is_save (ffesymbol_common (symbol))) + ffeequiv_update_save (eq); /* EQUIVALENCE is in a SAVEd COMMON block. */ + if (ffesymbol_is_init (ffesymbol_common (symbol))) + ffeequiv_update_init (eq); /* EQUIVALENCE is in a init'd COMMON block. */ + } + + ffeequiv_set_list (eq, ffebld_new_item (list, ffeequiv_list (eq))); +} + +/* ffeequiv_dump -- Dump info on equivalence object + + ffeequiv eq; + ffeequiv_dump(eq); */ + +void +ffeequiv_dump (ffeequiv eq) +{ + if (ffeequiv_common (eq) != NULL) + fprintf (dmpout, "(common %s) ", ffesymbol_text (ffeequiv_common (eq))); + ffebld_dump (ffeequiv_list (eq)); +} + +/* ffeequiv_exec_transition -- Do the hard work on all the equivalence objects + + ffeequiv_exec_transition(); */ + +void +ffeequiv_exec_transition () +{ + while (ffeequiv_list_.first != (ffeequiv) &ffeequiv_list_.first) + ffeequiv_layout_local_ (ffeequiv_list_.first); +} + +/* ffeequiv_init_2 -- Initialize for new program unit + + ffeequiv_init_2(); + + Initializes the list of equivalences. */ + +void +ffeequiv_init_2 () +{ + ffeequiv_list_.first = (ffeequiv) &ffeequiv_list_.first; + ffeequiv_list_.last = (ffeequiv) &ffeequiv_list_.first; +} + +/* ffeequiv_kill -- Kill equivalence object after removing from list + + ffeequiv eq; + ffeequiv_kill(eq); + + Removes equivalence object from master list, then kills it. */ + +void +ffeequiv_kill (ffeequiv victim) +{ + victim->next->previous = victim->previous; + victim->previous->next = victim->next; + if (ffe_is_do_internal_checks ()) + { + ffebld list; + ffebld item; + ffebld expr; + + /* Assert that nobody our victim points to still points to it. */ + + assert ((victim->common == NULL) + || (ffesymbol_equiv (victim->common) == NULL)); + + for (list = victim->list; list != NULL; list = ffebld_trail (list)) + { + for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item)) + { + ffesymbol sym; + + expr = ffebld_head (item); + sym = ffeequiv_symbol (expr); + if (sym == NULL) + continue; + assert (ffesymbol_equiv (sym) != victim); + } + } + } + malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim)); +} + +/* ffeequiv_layout_cblock -- Lay out storage for common area + + ffestorag st; + if (ffeequiv_layout_cblock(st)) + // at least one equiv'd symbol has init/accretion expr. + + Now that the explicitly COMMONed variables in the common area (whose + ffestorag object is passed) have been laid out, lay out the storage + for all variables equivalenced into the area by making subordinate + ffestorag objects for them. */ + +bool +ffeequiv_layout_cblock (ffestorag st) +{ + ffesymbol s = ffestorag_symbol (st); /* CBLOCK symbol. */ + ffebld list; /* List of explicit common vars, in order, in + s. */ + ffebld item; /* List of list of equivalences in a given + explicit common var. */ + ffebld root; /* Expression for (1st) explicit common var + in list of eqs. */ + ffestorag rst; /* Storage for root. */ + ffetargetOffset root_offset; /* Offset for root into common area. */ + ffesymbol sr; /* Root itself. */ + ffeequiv seq; /* Its equivalence object, if any. */ + ffebld var; /* Expression for equivalence. */ + ffestorag vst; /* Storage for var. */ + ffetargetOffset var_offset; /* Offset for var into common area. */ + ffesymbol sv; /* Var itself. */ + ffebld altroot; /* Alternate root. */ + ffesymbol altrootsym; /* Alternate root symbol. */ + ffetargetAlign alignment; + ffetargetAlign modulo; + ffetargetAlign pad; + ffetargetOffset size; + ffetargetOffset num_elements; + bool new_storage; /* Established new storage info. */ + bool need_storage; /* Have need for more storage info. */ + bool ok; + bool init = FALSE; + + assert (st != NULL); + assert (ffestorag_type (st) == FFESTORAG_typeCBLOCK); + assert (ffesymbol_kind (ffestorag_symbol (st)) == FFEINFO_kindCOMMON); + + for (list = ffesymbol_commonlist (ffestorag_symbol (st)); + list != NULL; + list = ffebld_trail (list)) + { /* For every variable in the common area */ + assert (ffebld_op (ffebld_head (list)) == FFEBLD_opSYMTER); + sr = ffebld_symter (ffebld_head (list)); + if ((seq = ffesymbol_equiv (sr)) == NULL) + continue; /* No equivalences to process. */ + rst = ffesymbol_storage (sr); + if (rst == NULL) + { + assert (ffesymbol_kind (sr) == FFEINFO_kindANY); + continue; + } + ffesymbol_set_equiv (sr, NULL); /* Cancel ref to equiv obj. */ + do + { + new_storage = FALSE; + need_storage = FALSE; + for (item = ffeequiv_list (seq); /* Get list of equivs. */ + item != NULL; + item = ffebld_trail (item)) + { /* For every eqv list in the list of equivs + for the variable */ + altroot = NULL; + altrootsym = NULL; + for (root = ffebld_head (item); + root != NULL; + root = ffebld_trail (root)) + { /* For every equivalence item in the list */ + sv = ffeequiv_symbol (ffebld_head (root)); + if (sv == sr) + break; /* Found first mention of "rooted" symbol. */ + if (ffesymbol_storage (sv) != NULL) + { + altroot = root; /* If no mention, use this guy + instead. */ + altrootsym = sv; + } + } + if (root != NULL) + { + root = ffebld_head (root); /* Lose its opITEM. */ + ok = ffeequiv_offset_ (&root_offset, sr, root, FALSE, + ffestorag_offset (rst), TRUE); + /* Equiv point prior to start of common area? */ + } + else if (altroot != NULL) + { + /* Equiv point prior to start of common area? */ + root = ffebld_head (altroot); + ok = ffeequiv_offset_ (&root_offset, altrootsym, root, + FALSE, + ffestorag_offset (ffesymbol_storage (altrootsym)), + TRUE); + ffesymbol_set_equiv (altrootsym, NULL); + } + else + /* No rooted symbol in list of equivalences! */ + { /* Assume this was due to opANY and ignore + this list for now. */ + need_storage = TRUE; + continue; + } + + /* We now know the root symbol and the operating offset of that + root into the common area. The other expressions in the + list all identify an initial storage unit that must have the + same offset. */ + + for (var = ffebld_head (item); + var != NULL; + var = ffebld_trail (var)) + { /* For every equivalence item in the list */ + if (ffebld_head (var) == root) + continue; /* Except root, of course. */ + sv = ffeequiv_symbol (ffebld_head (var)); + if (sv == NULL) + continue; /* Except erroneous stuff (opANY). */ + ffesymbol_set_equiv (sv, NULL); /* Don't need this ref + anymore. */ + if (!ok + || !ffeequiv_offset_ (&var_offset, sv, + ffebld_head (var), TRUE, + root_offset, TRUE)) + continue; /* Can't do negative offset wrt COMMON. */ + + if (ffesymbol_rank (sv) == 0) + num_elements = 1; + else + num_elements = ffebld_constant_integerdefault + (ffebld_conter (ffesymbol_arraysize (sv))); + ffetarget_layout (ffesymbol_text (sv), &alignment, + &modulo, &size, + ffesymbol_basictype (sv), + ffesymbol_kindtype (sv), + ffesymbol_size (sv), num_elements); + pad = ffetarget_align (ffestorag_ptr_to_alignment (st), + ffestorag_ptr_to_modulo (st), + var_offset, alignment, modulo); + if (pad != 0) + { + ffebad_start (FFEBAD_EQUIV_ALIGN); + ffebad_string (ffesymbol_text (sv)); + ffebad_finish (); + continue; + } + + if ((vst = ffesymbol_storage (sv)) == NULL) + { /* Create new ffestorag object, extend + cblock. */ + new_storage = TRUE; + vst = ffestorag_new (ffestorag_list_equivs (st)); + ffestorag_set_parent (vst, st); /* Initializations + happen there. */ + ffestorag_set_init (vst, NULL); + ffestorag_set_accretion (vst, NULL); + ffestorag_set_symbol (vst, sv); + ffestorag_set_size (vst, size); + ffestorag_set_offset (vst, var_offset); + ffestorag_set_alignment (vst, alignment); + ffestorag_set_modulo (vst, modulo); + ffestorag_set_type (vst, FFESTORAG_typeEQUIV); + ffestorag_set_basictype (vst, ffesymbol_basictype (sv)); + ffestorag_set_kindtype (vst, ffesymbol_kindtype (sv)); + ffestorag_set_typesymbol (vst, sv); + ffestorag_set_is_save (vst, FALSE); /* Assume FALSE... */ + if (ffestorag_is_save (st)) /* ...update TRUE */ + ffestorag_update_save (vst); /* if needed. */ + ffestorag_set_is_init (vst, FALSE); /* Assume FALSE... */ + if (ffestorag_is_init (st)) /* ...update TRUE */ + ffestorag_update_init (vst); /* if needed. */ + if (!ffetarget_offset_add (&size, var_offset, size)) + /* Find one size of common block, complain if + overflow. */ + ffetarget_offset_overflow (ffesymbol_text (s)); + else if (size > ffestorag_size (st)) + /* Extend common. */ + ffestorag_set_size (st, size); + ffesymbol_set_storage (sv, vst); + ffesymbol_set_common (sv, s); + ffesymbol_signal_unreported (sv); + ffestorag_update (st, sv, ffesymbol_basictype (sv), + ffesymbol_kindtype (sv)); + if (ffesymbol_is_init (sv)) + init = TRUE; + } + else + { + /* Make sure offset agrees with known offset. */ + if (var_offset != ffestorag_offset (vst)) + { + char io1[40]; + char io2[40]; + + sprintf (&io1[0], "%" ffetargetOffset_f "d", var_offset); + sprintf (&io2[0], "%" ffetargetOffset_f "d", ffestorag_offset (vst)); + ffebad_start (FFEBAD_EQUIV_MISMATCH); + ffebad_string (ffesymbol_text (sv)); + ffebad_string (ffesymbol_text (s)); + ffebad_string (io1); + ffebad_string (io2); + ffebad_finish (); + } + } + } /* (For every equivalence item in the list) */ + } /* (For every eqv list in the list of equivs + for the variable) */ + } + while (new_storage && need_storage); + + ffeequiv_kill (seq); /* Kill equiv obj. */ + } /* (For every variable in the common area) */ + + return init; +} + +/* ffeequiv_merge -- Merge two equivalence objects, return the merged result + + ffeequiv eq1; + ffeequiv eq2; + ffelexToken t; // points to current equivalence item forcing the merge. + eq1 = ffeequiv_merge(eq1,eq2,t); + + If the two equivalence objects can be merged, they are, all the + ffesymbols in their lists of lists are adjusted to point to the merged + equivalence object, and the merged object is returned. + + Otherwise, the two equivalence objects have different non-NULL common + symbols, so the merge cannot take place. An error message is issued and + NULL is returned. */ + +ffeequiv +ffeequiv_merge (ffeequiv eq1, ffeequiv eq2, ffelexToken t) +{ + ffebld list; + ffebld eqs; + ffesymbol symbol; + ffebld last = NULL; + + /* If both equivalence objects point to different common-based symbols, + complain. Of course, one or both might have NULL common symbols now, + and get COMMONed later, but the COMMON statement handler checks for + this. */ + + if ((ffeequiv_common (eq1) != NULL) && (ffeequiv_common (eq2) != NULL) + && (ffeequiv_common (eq1) != ffeequiv_common (eq2))) + { + ffebad_start (FFEBAD_EQUIV_COMMON); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_string (ffesymbol_text (ffeequiv_common (eq1))); + ffebad_string (ffesymbol_text (ffeequiv_common (eq2))); + ffebad_finish (); + return NULL; + } + + /* Make eq1 the new, merged object (arbitrarily). */ + + if (ffeequiv_common (eq1) == NULL) + ffeequiv_set_common (eq1, ffeequiv_common (eq2)); + + /* If the victim object has any init'ed entities, so does the new object. */ + + if (eq2->is_init) + eq1->is_init = TRUE; + +#if FFEGLOBAL_ENABLED + if (eq1->is_init && (ffeequiv_common (eq1) != NULL)) + ffeglobal_init_common (ffeequiv_common (eq1), t); +#endif + + /* If the victim object has any SAVEd entities, then the new object has + some. */ + + if (ffeequiv_is_save (eq2)) + ffeequiv_update_save (eq1); + + /* If the victim object has any init'd entities, then the new object has + some. */ + + if (ffeequiv_is_init (eq2)) + ffeequiv_update_init (eq1); + + /* Adjust all the symbols in the list of lists of equivalences for the + victim equivalence object so they point to the new merged object + instead. */ + + for (list = ffeequiv_list (eq2); list != NULL; list = ffebld_trail (list)) + { + for (eqs = ffebld_head (list); eqs != NULL; eqs = ffebld_trail (eqs)) + { + symbol = ffeequiv_symbol (ffebld_head (eqs)); + if (ffesymbol_equiv (symbol) == eq2) + ffesymbol_set_equiv (symbol, eq1); + else + assert (ffesymbol_equiv (symbol) == eq1); /* Can see a sym > once. */ + } + + /* For convenience, remember where the last ITEM in the outer list is. */ + + if (ffebld_trail (list) == NULL) + { + last = list; + break; + } + } + + /* Append the list of lists in the new, merged object to the list of lists + in the victim object, then use the new combined list in the new merged + object. */ + + ffebld_set_trail (last, ffeequiv_list (eq1)); + ffeequiv_set_list (eq1, ffeequiv_list (eq2)); + + /* Unlink and kill the victim object. */ + + ffeequiv_kill (eq2); + + return eq1; /* Return the new merged object. */ +} + +/* ffeequiv_new -- Create new equivalence object, put in list + + ffeequiv eq; + eq = ffeequiv_new(); + + Creates a new equivalence object and adds it to the list of equivalence + objects. */ + +ffeequiv +ffeequiv_new () +{ + ffeequiv eq; + + eq = malloc_new_ks (ffe_pool_program_unit (), "ffeequiv", sizeof (*eq)); + eq->next = (ffeequiv) &ffeequiv_list_.first; + eq->previous = ffeequiv_list_.last; + ffeequiv_set_common (eq, NULL); /* No COMMON area yet. */ + ffeequiv_set_list (eq, NULL); /* No list of lists of equivalences yet. */ + ffeequiv_set_is_save (eq, FALSE); + ffeequiv_set_is_init (eq, FALSE); + eq->next->previous = eq; + eq->previous->next = eq; + + return eq; +} + +/* ffeequiv_symbol -- Return symbol for equivalence expression + + ffesymbol symbol; + ffebld expr; + symbol = ffeequiv_symbol(expr); + + Finds the terminal SYMTER in an equivalence expression and returns the + ffesymbol for it. */ + +ffesymbol +ffeequiv_symbol (ffebld expr) +{ + assert (expr != NULL); + +again: /* :::::::::::::::::::: */ + + switch (ffebld_op (expr)) + { + case FFEBLD_opARRAYREF: + case FFEBLD_opSUBSTR: + expr = ffebld_left (expr); + goto again; /* :::::::::::::::::::: */ + + case FFEBLD_opSYMTER: + return ffebld_symter (expr); + + case FFEBLD_opANY: + return NULL; + + default: + assert ("bad eq expr" == NULL); + return NULL; + } +} + +/* ffeequiv_update_init -- Update the INIT flag for the area to TRUE + + ffeequiv eq; + ffeequiv_update_init(eq); + + If the INIT flag for the object is already set, return. Else, + set it TRUE and call ffe*_update_init for all objects contained in + this one. */ + +void +ffeequiv_update_init (ffeequiv eq) +{ + ffebld list; /* Current list in list of lists. */ + ffebld item; /* Current item in current list. */ + ffebld expr; /* Expression in head of current item. */ + + if (eq->is_init) + return; + + eq->is_init = TRUE; + + if ((eq->common != NULL) + && !ffesymbol_is_init (eq->common)) + ffesymbol_update_init (eq->common); /* Shouldn't be needed. */ + + for (list = eq->list; list != NULL; list = ffebld_trail (list)) + { + for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item)) + { + expr = ffebld_head (item); + + again: /* :::::::::::::::::::: */ + + switch (ffebld_op (expr)) + { + case FFEBLD_opANY: + break; + + case FFEBLD_opSYMTER: + if (!ffesymbol_is_init (ffebld_symter (expr))) + ffesymbol_update_init (ffebld_symter (expr)); + break; + + case FFEBLD_opARRAYREF: + expr = ffebld_left (expr); + goto again; /* :::::::::::::::::::: */ + + case FFEBLD_opSUBSTR: + expr = ffebld_left (expr); + goto again; /* :::::::::::::::::::: */ + + default: + assert ("bad op for ffeequiv_update_init" == NULL); + break; + } + } + } +} + +/* ffeequiv_update_save -- Update the SAVE flag for the area to TRUE + + ffeequiv eq; + ffeequiv_update_save(eq); + + If the SAVE flag for the object is already set, return. Else, + set it TRUE and call ffe*_update_save for all objects contained in + this one. */ + +void +ffeequiv_update_save (ffeequiv eq) +{ + ffebld list; /* Current list in list of lists. */ + ffebld item; /* Current item in current list. */ + ffebld expr; /* Expression in head of current item. */ + + if (eq->is_save) + return; + + eq->is_save = TRUE; + + if ((eq->common != NULL) + && !ffesymbol_is_save (eq->common)) + ffesymbol_update_save (eq->common); /* Shouldn't be needed. */ + + for (list = eq->list; list != NULL; list = ffebld_trail (list)) + { + for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item)) + { + expr = ffebld_head (item); + + again: /* :::::::::::::::::::: */ + + switch (ffebld_op (expr)) + { + case FFEBLD_opANY: + break; + + case FFEBLD_opSYMTER: + if (!ffesymbol_is_save (ffebld_symter (expr))) + ffesymbol_update_save (ffebld_symter (expr)); + break; + + case FFEBLD_opARRAYREF: + expr = ffebld_left (expr); + goto again; /* :::::::::::::::::::: */ + + case FFEBLD_opSUBSTR: + expr = ffebld_left (expr); + goto again; /* :::::::::::::::::::: */ + + default: + assert ("bad op for ffeequiv_update_save" == NULL); + break; + } + } + } +} diff --git a/gcc/f/equiv.h b/gcc/f/equiv.h new file mode 100644 index 000000000000..225cafded1b8 --- /dev/null +++ b/gcc/f/equiv.h @@ -0,0 +1,101 @@ +/* equiv.h -- Public #include File (module.h template V1.0) + Copyright (C) 1995, 1996 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + equiv.c + + Modifications: +*/ + +/* Allow multiple inclusion to work. */ + +#ifndef _H_f_equiv +#define _H_f_equiv + +/* Simple definitions and enumerations. */ + + +/* Typedefs. */ + +typedef struct _ffeequiv_ *ffeequiv; + +/* Include files needed by this one. */ + +#include "bld.h" +#include "lex.h" +#include "storag.h" +#include "symbol.h" + +/* Structure definitions. */ + +struct _ffeequiv_ + { + ffeequiv next; + ffeequiv previous; + ffesymbol common; /* Common area for this equiv, if any. */ + ffebld list; /* List of lists of equiv exprs. */ + bool is_save; /* Any SAVEd members? */ + bool is_init; /* Any initialized members? */ + }; + +/* Global objects accessed by users of this module. */ + + +/* Declare functions with prototypes. */ + +void ffeequiv_add (ffeequiv eq, ffebld list, ffelexToken t); +void ffeequiv_dump (ffeequiv eq); +void ffeequiv_exec_transition (void); +void ffeequiv_init_2 (void); +void ffeequiv_kill (ffeequiv victim); +bool ffeequiv_layout_cblock (ffestorag st); +ffeequiv ffeequiv_merge (ffeequiv eq1, ffeequiv eq2, ffelexToken t); +ffeequiv ffeequiv_new (void); +ffesymbol ffeequiv_symbol (ffebld expr); +void ffeequiv_update_init (ffeequiv eq); +void ffeequiv_update_save (ffeequiv eq); + +/* Define macros. */ + +#define ffeequiv_common(e) ((e)->common) +#define ffeequiv_init_0() +#define ffeequiv_init_1() +#define ffeequiv_init_3() +#define ffeequiv_init_4() +#define ffeequiv_is_init(e) ((e)->is_init) +#define ffeequiv_is_save(e) ((e)->is_save) +#define ffeequiv_list(e) ((e)->list) +#define ffeequiv_next(e) ((e)->next) +#define ffeequiv_previous(e) ((e)->previous) +#define ffeequiv_set_common(e,c) ((e)->common = (c)) +#define ffeequiv_set_init(e,i) ((e)->init = (i)) +#define ffeequiv_set_is_init(e,in) ((e)->is_init = (in)) +#define ffeequiv_set_is_save(e,sa) ((e)->is_save = (sa)) +#define ffeequiv_set_list(e,l) ((e)->list = (l)) +#define ffeequiv_terminate_0() +#define ffeequiv_terminate_1() +#define ffeequiv_terminate_2() +#define ffeequiv_terminate_3() +#define ffeequiv_terminate_4() + +/* End of #include file. */ + +#endif diff --git a/gcc/f/expr.c b/gcc/f/expr.c new file mode 100644 index 000000000000..057293b0eefd --- /dev/null +++ b/gcc/f/expr.c @@ -0,0 +1,19405 @@ +/* expr.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995-1997 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + None. + + Description: + Handles syntactic and semantic analysis of Fortran expressions. + + Modifications: +*/ + +/* Include files. */ + +#include "proj.h" +#include +#include "expr.h" +#include "bad.h" +#include "bld.h" +#include "com.h" +#include "global.h" +#include "implic.h" +#include "intrin.h" +#include "info.h" +#include "lex.h" +#include "malloc.h" +#include "src.h" +#include "st.h" +#include "symbol.h" +#include "target.h" +#include "where.h" + +/* Externals defined here. */ + + +/* Simple definitions and enumerations. */ + +typedef enum + { + FFEEXPR_dotdotNONE_, + FFEEXPR_dotdotTRUE_, + FFEEXPR_dotdotFALSE_, + FFEEXPR_dotdotNOT_, + FFEEXPR_dotdotAND_, + FFEEXPR_dotdotOR_, + FFEEXPR_dotdotXOR_, + FFEEXPR_dotdotEQV_, + FFEEXPR_dotdotNEQV_, + FFEEXPR_dotdotLT_, + FFEEXPR_dotdotLE_, + FFEEXPR_dotdotEQ_, + FFEEXPR_dotdotNE_, + FFEEXPR_dotdotGT_, + FFEEXPR_dotdotGE_, + FFEEXPR_dotdot + } ffeexprDotdot_; + +typedef enum + { + FFEEXPR_exprtypeUNKNOWN_, + FFEEXPR_exprtypeOPERAND_, + FFEEXPR_exprtypeUNARY_, + FFEEXPR_exprtypeBINARY_, + FFEEXPR_exprtype_ + } ffeexprExprtype_; + +typedef enum + { + FFEEXPR_operatorPOWER_, + FFEEXPR_operatorMULTIPLY_, + FFEEXPR_operatorDIVIDE_, + FFEEXPR_operatorADD_, + FFEEXPR_operatorSUBTRACT_, + FFEEXPR_operatorCONCATENATE_, + FFEEXPR_operatorLT_, + FFEEXPR_operatorLE_, + FFEEXPR_operatorEQ_, + FFEEXPR_operatorNE_, + FFEEXPR_operatorGT_, + FFEEXPR_operatorGE_, + FFEEXPR_operatorNOT_, + FFEEXPR_operatorAND_, + FFEEXPR_operatorOR_, + FFEEXPR_operatorXOR_, + FFEEXPR_operatorEQV_, + FFEEXPR_operatorNEQV_, + FFEEXPR_operator_ + } ffeexprOperator_; + +typedef enum + { + FFEEXPR_operatorprecedenceHIGHEST_ = 1, + FFEEXPR_operatorprecedencePOWER_ = 1, + FFEEXPR_operatorprecedenceMULTIPLY_ = 2, + FFEEXPR_operatorprecedenceDIVIDE_ = 2, + FFEEXPR_operatorprecedenceADD_ = 3, + FFEEXPR_operatorprecedenceSUBTRACT_ = 3, + FFEEXPR_operatorprecedenceLOWARITH_ = 3, + FFEEXPR_operatorprecedenceCONCATENATE_ = 3, + FFEEXPR_operatorprecedenceLT_ = 4, + FFEEXPR_operatorprecedenceLE_ = 4, + FFEEXPR_operatorprecedenceEQ_ = 4, + FFEEXPR_operatorprecedenceNE_ = 4, + FFEEXPR_operatorprecedenceGT_ = 4, + FFEEXPR_operatorprecedenceGE_ = 4, + FFEEXPR_operatorprecedenceNOT_ = 5, + FFEEXPR_operatorprecedenceAND_ = 6, + FFEEXPR_operatorprecedenceOR_ = 7, + FFEEXPR_operatorprecedenceXOR_ = 8, + FFEEXPR_operatorprecedenceEQV_ = 8, + FFEEXPR_operatorprecedenceNEQV_ = 8, + FFEEXPR_operatorprecedenceLOWEST_ = 8, + FFEEXPR_operatorprecedence_ + } ffeexprOperatorPrecedence_; + +#define FFEEXPR_operatorassociativityL2R_ TRUE +#define FFEEXPR_operatorassociativityR2L_ FALSE +#define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_ +#define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_ +#define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_ +#define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_ +#define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_ +#define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_ +#define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_ +#define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_ +#define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_ +#define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_ +#define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_ +#define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_ +#define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_ +#define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_ +#define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_ +#define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_ +#define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_ +#define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_ + +typedef enum + { + FFEEXPR_parentypeFUNCTION_, + FFEEXPR_parentypeSUBROUTINE_, + FFEEXPR_parentypeARRAY_, + FFEEXPR_parentypeSUBSTRING_, + FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */ + FFEEXPR_parentypeEQUIVALENCE_, /* Ambig: ARRAY_ or SUBSTRING_. */ + FFEEXPR_parentypeANY_, /* Allow basically anything. */ + FFEEXPR_parentype_ + } ffeexprParenType_; + +typedef enum + { + FFEEXPR_percentNONE_, + FFEEXPR_percentLOC_, + FFEEXPR_percentVAL_, + FFEEXPR_percentREF_, + FFEEXPR_percentDESCR_, + FFEEXPR_percent_ + } ffeexprPercent_; + +/* Internal typedefs. */ + +typedef struct _ffeexpr_expr_ *ffeexprExpr_; +typedef bool ffeexprOperatorAssociativity_; +typedef struct _ffeexpr_stack_ *ffeexprStack_; + +/* Private include files. */ + + +/* Internal structure definitions. */ + +struct _ffeexpr_expr_ + { + ffeexprExpr_ previous; + ffelexToken token; + ffeexprExprtype_ type; + union + { + struct + { + ffeexprOperator_ op; + ffeexprOperatorPrecedence_ prec; + ffeexprOperatorAssociativity_ as; + } + operator; + ffebld operand; + } + u; + }; + +struct _ffeexpr_stack_ + { + ffeexprStack_ previous; + mallocPool pool; + ffeexprContext context; + ffeexprCallback callback; + ffelexToken first_token; + ffeexprExpr_ exprstack; + ffelexToken tokens[10]; /* Used in certain cases, like (unary) + open-paren. */ + ffebld expr; /* For first of + complex/implied-do/substring/array-elements + / actual-args expression. */ + ffebld bound_list; /* For tracking dimension bounds list of + array. */ + ffebldListBottom bottom; /* For building lists. */ + ffeinfoRank rank; /* For elements in an array reference. */ + bool constant; /* TRUE while elements seen so far are + constants. */ + bool immediate; /* TRUE while elements seen so far are + immediate/constants. */ + ffebld next_dummy; /* Next SFUNC dummy arg in arg list. */ + ffebldListLength num_args; /* Number of dummy args expected in arg list. */ + bool is_rhs; /* TRUE if rhs context, FALSE otherwise. */ + ffeexprPercent_ percent; /* Current %FOO keyword. */ + }; + +struct _ffeexpr_find_ + { + ffelexToken t; + ffelexHandler after; + int level; + }; + +/* Static objects accessed by functions in this module. */ + +static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */ +static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */ +static ffeexprDotdot_ ffeexpr_current_dotdot_; /* Current .FOO. keyword. */ +static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */ +static int ffeexpr_level_; /* Level of DATA implied-DO construct. */ +static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */ +static struct _ffeexpr_find_ ffeexpr_find_; + +/* Static functions (internal). */ + +static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, + ffebld expr, + ffelexToken t); +static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t); +static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft, + ffebld expr, ffelexToken t); +static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft, + ffebld expr, ffelexToken t); +static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t); +static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t); +static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s); +static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t, + ffebld dovar, ffelexToken dovar_t); +static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar); +static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar); +static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s); +static ffeexprDotdot_ ffeexpr_dotdot_ (ffelexToken t); +static ffeexprExpr_ ffeexpr_expr_new_ (void); +static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t); +static bool ffeexpr_isdigits_ (char *p); +static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t); +static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t); +static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t); +static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t); +static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t); +static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t); +static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t); +static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t); +static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t); +static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t); +static void ffeexpr_expr_kill_ (ffeexprExpr_ e); +static void ffeexpr_exprstack_push_ (ffeexprExpr_ e); +static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e); +static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e); +static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e); +static void ffeexpr_reduce_ (void); +static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, + ffeexprExpr_ r); +static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, + ffeexprExpr_ op, ffeexprExpr_ r); +static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, + ffeexprExpr_ op, ffeexprExpr_ r); +static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, + ffeexprExpr_ op, ffeexprExpr_ r); +static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, + ffeexprExpr_ r); +static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, + ffeexprExpr_ op, ffeexprExpr_ r); +static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, + ffeexprExpr_ op, ffeexprExpr_ r); +static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, + ffeexprExpr_ op, ffeexprExpr_ r); +static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r); +static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, + ffeexprExpr_ r); +static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, + ffeexprExpr_ op, ffeexprExpr_ r); +static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, + ffeexprExpr_ op, ffeexprExpr_ r); +static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t, + ffelexHandler after); +static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_period_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_real_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_number_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t); +static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t); +static ffelexHandler ffeexpr_finished_ (ffelexToken t); +static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr); +static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t); +static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t); +static ffelexHandler ffeexpr_token_binary_ (ffelexToken t); +static ffelexHandler ffeexpr_token_period_ (ffelexToken t); +static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t); +static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t); +static ffelexHandler ffeexpr_token_real_ (ffelexToken t); +static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t); +static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t); +static ffelexHandler ffeexpr_token_number_ (ffelexToken t); +static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t); +static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t); +static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t); +static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t); +static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t); +static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t); +static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t); +static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t); +static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t); +static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t); +static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t); +static ffelexHandler ffeexpr_token_quote_ (ffelexToken t); +static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t); +static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t); +static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t); +static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t); +static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t); +static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t); +static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t); +static ffelexHandler ffeexpr_token_percent_ (ffelexToken t); +static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t); +static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t); +static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t); +static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer, + ffelexToken decimal, ffelexToken fraction, ffelexToken exponent, + ffelexToken exponent_sign, ffelexToken exponent_digits); +static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin); +static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t); +static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t); +static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t); +static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t); +static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t); +static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t); +static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t); +static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t); +static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t); +static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t); +static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t, + bool maybe_intrin, + ffeexprParenType_ *paren_type); +static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t); + +/* Internal macros. */ + +#define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t) +#define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t) + +/* ffeexpr_collapse_convert -- Collapse convert expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_convert(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_convert (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebldConstantUnion u; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffetargetCharacterSize sz; + ffetargetCharacterSize sz2; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + + switch (bt = ffeinfo_basictype (ffebld_info (expr))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + sz = FFETARGET_charactersizeNONE; + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + switch (ffeinfo_basictype (ffebld_info (l))) + { + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_convert_integer1_integer2 + (ffebld_cu_ptr_integer1 (u), + ffebld_constant_integer2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_convert_integer1_integer3 + (ffebld_cu_ptr_integer1 (u), + ffebld_constant_integer3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_convert_integer1_integer4 + (ffebld_cu_ptr_integer1 (u), + ffebld_constant_integer4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("INTEGER1/INTEGER bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_integer1_real1 + (ffebld_cu_ptr_integer1 (u), + ffebld_constant_real1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_integer1_real2 + (ffebld_cu_ptr_integer1 (u), + ffebld_constant_real2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_integer1_real3 + (ffebld_cu_ptr_integer1 (u), + ffebld_constant_real3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_integer1_real4 + (ffebld_cu_ptr_integer1 (u), + ffebld_constant_real4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("INTEGER1/REAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_integer1_complex1 + (ffebld_cu_ptr_integer1 (u), + ffebld_constant_complex1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_integer1_complex2 + (ffebld_cu_ptr_integer1 (u), + ffebld_constant_complex2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_integer1_complex3 + (ffebld_cu_ptr_integer1 (u), + ffebld_constant_complex3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_integer1_complex4 + (ffebld_cu_ptr_integer1 (u), + ffebld_constant_complex4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("INTEGER1/COMPLEX bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + error = ffetarget_convert_integer1_logical1 + (ffebld_cu_ptr_integer1 (u), + ffebld_constant_logical1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + error = ffetarget_convert_integer1_logical2 + (ffebld_cu_ptr_integer1 (u), + ffebld_constant_logical2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + error = ffetarget_convert_integer1_logical3 + (ffebld_cu_ptr_integer1 (u), + ffebld_constant_logical3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + error = ffetarget_convert_integer1_logical4 + (ffebld_cu_ptr_integer1 (u), + ffebld_constant_logical4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("INTEGER1/LOGICAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + error = ffetarget_convert_integer1_character1 + (ffebld_cu_ptr_integer1 (u), + ffebld_constant_character1 (ffebld_conter (l))); + break; + + case FFEINFO_basictypeHOLLERITH: + error = ffetarget_convert_integer1_hollerith + (ffebld_cu_ptr_integer1 (u), + ffebld_constant_hollerith (ffebld_conter (l))); + break; + + case FFEINFO_basictypeTYPELESS: + error = ffetarget_convert_integer1_typeless + (ffebld_cu_ptr_integer1 (u), + ffebld_constant_typeless (ffebld_conter (l))); + break; + + default: + assert ("INTEGER1 bad type" == NULL); + break; + } + + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_integer1_val + (ffebld_cu_val_integer1 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + switch (ffeinfo_basictype (ffebld_info (l))) + { + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_convert_integer2_integer1 + (ffebld_cu_ptr_integer2 (u), + ffebld_constant_integer1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_convert_integer2_integer3 + (ffebld_cu_ptr_integer2 (u), + ffebld_constant_integer3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_convert_integer2_integer4 + (ffebld_cu_ptr_integer2 (u), + ffebld_constant_integer4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("INTEGER2/INTEGER bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_integer2_real1 + (ffebld_cu_ptr_integer2 (u), + ffebld_constant_real1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_integer2_real2 + (ffebld_cu_ptr_integer2 (u), + ffebld_constant_real2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_integer2_real3 + (ffebld_cu_ptr_integer2 (u), + ffebld_constant_real3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_integer2_real4 + (ffebld_cu_ptr_integer2 (u), + ffebld_constant_real4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("INTEGER2/REAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_integer2_complex1 + (ffebld_cu_ptr_integer2 (u), + ffebld_constant_complex1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_integer2_complex2 + (ffebld_cu_ptr_integer2 (u), + ffebld_constant_complex2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_integer2_complex3 + (ffebld_cu_ptr_integer2 (u), + ffebld_constant_complex3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_integer2_complex4 + (ffebld_cu_ptr_integer2 (u), + ffebld_constant_complex4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("INTEGER2/COMPLEX bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + error = ffetarget_convert_integer2_logical1 + (ffebld_cu_ptr_integer2 (u), + ffebld_constant_logical1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + error = ffetarget_convert_integer2_logical2 + (ffebld_cu_ptr_integer2 (u), + ffebld_constant_logical2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + error = ffetarget_convert_integer2_logical3 + (ffebld_cu_ptr_integer2 (u), + ffebld_constant_logical3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + error = ffetarget_convert_integer2_logical4 + (ffebld_cu_ptr_integer2 (u), + ffebld_constant_logical4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("INTEGER2/LOGICAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + error = ffetarget_convert_integer2_character1 + (ffebld_cu_ptr_integer2 (u), + ffebld_constant_character1 (ffebld_conter (l))); + break; + + case FFEINFO_basictypeHOLLERITH: + error = ffetarget_convert_integer2_hollerith + (ffebld_cu_ptr_integer2 (u), + ffebld_constant_hollerith (ffebld_conter (l))); + break; + + case FFEINFO_basictypeTYPELESS: + error = ffetarget_convert_integer2_typeless + (ffebld_cu_ptr_integer2 (u), + ffebld_constant_typeless (ffebld_conter (l))); + break; + + default: + assert ("INTEGER2 bad type" == NULL); + break; + } + + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_integer2_val + (ffebld_cu_val_integer2 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + switch (ffeinfo_basictype (ffebld_info (l))) + { + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_convert_integer3_integer1 + (ffebld_cu_ptr_integer3 (u), + ffebld_constant_integer1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_convert_integer3_integer2 + (ffebld_cu_ptr_integer3 (u), + ffebld_constant_integer2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_convert_integer3_integer4 + (ffebld_cu_ptr_integer3 (u), + ffebld_constant_integer4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("INTEGER3/INTEGER bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_integer3_real1 + (ffebld_cu_ptr_integer3 (u), + ffebld_constant_real1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_integer3_real2 + (ffebld_cu_ptr_integer3 (u), + ffebld_constant_real2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_integer3_real3 + (ffebld_cu_ptr_integer3 (u), + ffebld_constant_real3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_integer3_real4 + (ffebld_cu_ptr_integer3 (u), + ffebld_constant_real4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("INTEGER3/REAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_integer3_complex1 + (ffebld_cu_ptr_integer3 (u), + ffebld_constant_complex1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_integer3_complex2 + (ffebld_cu_ptr_integer3 (u), + ffebld_constant_complex2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_integer3_complex3 + (ffebld_cu_ptr_integer3 (u), + ffebld_constant_complex3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_integer3_complex4 + (ffebld_cu_ptr_integer3 (u), + ffebld_constant_complex4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("INTEGER3/COMPLEX bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + error = ffetarget_convert_integer3_logical1 + (ffebld_cu_ptr_integer3 (u), + ffebld_constant_logical1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + error = ffetarget_convert_integer3_logical2 + (ffebld_cu_ptr_integer3 (u), + ffebld_constant_logical2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + error = ffetarget_convert_integer3_logical3 + (ffebld_cu_ptr_integer3 (u), + ffebld_constant_logical3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + error = ffetarget_convert_integer3_logical4 + (ffebld_cu_ptr_integer3 (u), + ffebld_constant_logical4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("INTEGER3/LOGICAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + error = ffetarget_convert_integer3_character1 + (ffebld_cu_ptr_integer3 (u), + ffebld_constant_character1 (ffebld_conter (l))); + break; + + case FFEINFO_basictypeHOLLERITH: + error = ffetarget_convert_integer3_hollerith + (ffebld_cu_ptr_integer3 (u), + ffebld_constant_hollerith (ffebld_conter (l))); + break; + + case FFEINFO_basictypeTYPELESS: + error = ffetarget_convert_integer3_typeless + (ffebld_cu_ptr_integer3 (u), + ffebld_constant_typeless (ffebld_conter (l))); + break; + + default: + assert ("INTEGER3 bad type" == NULL); + break; + } + + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_integer3_val + (ffebld_cu_val_integer3 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + switch (ffeinfo_basictype (ffebld_info (l))) + { + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_convert_integer4_integer1 + (ffebld_cu_ptr_integer4 (u), + ffebld_constant_integer1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_convert_integer4_integer2 + (ffebld_cu_ptr_integer4 (u), + ffebld_constant_integer2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_convert_integer4_integer3 + (ffebld_cu_ptr_integer4 (u), + ffebld_constant_integer3 (ffebld_conter (l))); + break; +#endif + + default: + assert ("INTEGER4/INTEGER bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_integer4_real1 + (ffebld_cu_ptr_integer4 (u), + ffebld_constant_real1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_integer4_real2 + (ffebld_cu_ptr_integer4 (u), + ffebld_constant_real2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_integer4_real3 + (ffebld_cu_ptr_integer4 (u), + ffebld_constant_real3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_integer4_real4 + (ffebld_cu_ptr_integer4 (u), + ffebld_constant_real4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("INTEGER4/REAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_integer4_complex1 + (ffebld_cu_ptr_integer4 (u), + ffebld_constant_complex1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_integer4_complex2 + (ffebld_cu_ptr_integer4 (u), + ffebld_constant_complex2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_integer4_complex3 + (ffebld_cu_ptr_integer4 (u), + ffebld_constant_complex3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_integer4_complex4 + (ffebld_cu_ptr_integer4 (u), + ffebld_constant_complex4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("INTEGER3/COMPLEX bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + error = ffetarget_convert_integer4_logical1 + (ffebld_cu_ptr_integer4 (u), + ffebld_constant_logical1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + error = ffetarget_convert_integer4_logical2 + (ffebld_cu_ptr_integer4 (u), + ffebld_constant_logical2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + error = ffetarget_convert_integer4_logical3 + (ffebld_cu_ptr_integer4 (u), + ffebld_constant_logical3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + error = ffetarget_convert_integer4_logical4 + (ffebld_cu_ptr_integer4 (u), + ffebld_constant_logical4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("INTEGER4/LOGICAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + error = ffetarget_convert_integer4_character1 + (ffebld_cu_ptr_integer4 (u), + ffebld_constant_character1 (ffebld_conter (l))); + break; + + case FFEINFO_basictypeHOLLERITH: + error = ffetarget_convert_integer4_hollerith + (ffebld_cu_ptr_integer4 (u), + ffebld_constant_hollerith (ffebld_conter (l))); + break; + + case FFEINFO_basictypeTYPELESS: + error = ffetarget_convert_integer4_typeless + (ffebld_cu_ptr_integer4 (u), + ffebld_constant_typeless (ffebld_conter (l))); + break; + + default: + assert ("INTEGER4 bad type" == NULL); + break; + } + + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_integer4_val + (ffebld_cu_val_integer4 (u)), expr); + break; +#endif + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + sz = FFETARGET_charactersizeNONE; + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + switch (ffeinfo_basictype (ffebld_info (l))) + { + case FFEINFO_basictypeLOGICAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + error = ffetarget_convert_logical1_logical2 + (ffebld_cu_ptr_logical1 (u), + ffebld_constant_logical2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + error = ffetarget_convert_logical1_logical3 + (ffebld_cu_ptr_logical1 (u), + ffebld_constant_logical3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + error = ffetarget_convert_logical1_logical4 + (ffebld_cu_ptr_logical1 (u), + ffebld_constant_logical4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("LOGICAL1/LOGICAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_convert_logical1_integer1 + (ffebld_cu_ptr_logical1 (u), + ffebld_constant_integer1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_convert_logical1_integer2 + (ffebld_cu_ptr_logical1 (u), + ffebld_constant_integer2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_convert_logical1_integer3 + (ffebld_cu_ptr_logical1 (u), + ffebld_constant_integer3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_convert_logical1_integer4 + (ffebld_cu_ptr_logical1 (u), + ffebld_constant_integer4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("LOGICAL1/INTEGER bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + error = ffetarget_convert_logical1_character1 + (ffebld_cu_ptr_logical1 (u), + ffebld_constant_character1 (ffebld_conter (l))); + break; + + case FFEINFO_basictypeHOLLERITH: + error = ffetarget_convert_logical1_hollerith + (ffebld_cu_ptr_logical1 (u), + ffebld_constant_hollerith (ffebld_conter (l))); + break; + + case FFEINFO_basictypeTYPELESS: + error = ffetarget_convert_logical1_typeless + (ffebld_cu_ptr_logical1 (u), + ffebld_constant_typeless (ffebld_conter (l))); + break; + + default: + assert ("LOGICAL1 bad type" == NULL); + break; + } + + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logical1_val + (ffebld_cu_val_logical1 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + switch (ffeinfo_basictype (ffebld_info (l))) + { + case FFEINFO_basictypeLOGICAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + error = ffetarget_convert_logical2_logical1 + (ffebld_cu_ptr_logical2 (u), + ffebld_constant_logical1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + error = ffetarget_convert_logical2_logical3 + (ffebld_cu_ptr_logical2 (u), + ffebld_constant_logical3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + error = ffetarget_convert_logical2_logical4 + (ffebld_cu_ptr_logical2 (u), + ffebld_constant_logical4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("LOGICAL2/LOGICAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_convert_logical2_integer1 + (ffebld_cu_ptr_logical2 (u), + ffebld_constant_integer1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_convert_logical2_integer2 + (ffebld_cu_ptr_logical2 (u), + ffebld_constant_integer2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_convert_logical2_integer3 + (ffebld_cu_ptr_logical2 (u), + ffebld_constant_integer3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_convert_logical2_integer4 + (ffebld_cu_ptr_logical2 (u), + ffebld_constant_integer4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("LOGICAL2/INTEGER bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + error = ffetarget_convert_logical2_character1 + (ffebld_cu_ptr_logical2 (u), + ffebld_constant_character1 (ffebld_conter (l))); + break; + + case FFEINFO_basictypeHOLLERITH: + error = ffetarget_convert_logical2_hollerith + (ffebld_cu_ptr_logical2 (u), + ffebld_constant_hollerith (ffebld_conter (l))); + break; + + case FFEINFO_basictypeTYPELESS: + error = ffetarget_convert_logical2_typeless + (ffebld_cu_ptr_logical2 (u), + ffebld_constant_typeless (ffebld_conter (l))); + break; + + default: + assert ("LOGICAL2 bad type" == NULL); + break; + } + + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logical2_val + (ffebld_cu_val_logical2 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + switch (ffeinfo_basictype (ffebld_info (l))) + { + case FFEINFO_basictypeLOGICAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + error = ffetarget_convert_logical3_logical1 + (ffebld_cu_ptr_logical3 (u), + ffebld_constant_logical1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + error = ffetarget_convert_logical3_logical2 + (ffebld_cu_ptr_logical3 (u), + ffebld_constant_logical2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + error = ffetarget_convert_logical3_logical4 + (ffebld_cu_ptr_logical3 (u), + ffebld_constant_logical4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("LOGICAL3/LOGICAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_convert_logical3_integer1 + (ffebld_cu_ptr_logical3 (u), + ffebld_constant_integer1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_convert_logical3_integer2 + (ffebld_cu_ptr_logical3 (u), + ffebld_constant_integer2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_convert_logical3_integer3 + (ffebld_cu_ptr_logical3 (u), + ffebld_constant_integer3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_convert_logical3_integer4 + (ffebld_cu_ptr_logical3 (u), + ffebld_constant_integer4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("LOGICAL3/INTEGER bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + error = ffetarget_convert_logical3_character1 + (ffebld_cu_ptr_logical3 (u), + ffebld_constant_character1 (ffebld_conter (l))); + break; + + case FFEINFO_basictypeHOLLERITH: + error = ffetarget_convert_logical3_hollerith + (ffebld_cu_ptr_logical3 (u), + ffebld_constant_hollerith (ffebld_conter (l))); + break; + + case FFEINFO_basictypeTYPELESS: + error = ffetarget_convert_logical3_typeless + (ffebld_cu_ptr_logical3 (u), + ffebld_constant_typeless (ffebld_conter (l))); + break; + + default: + assert ("LOGICAL3 bad type" == NULL); + break; + } + + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logical3_val + (ffebld_cu_val_logical3 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + switch (ffeinfo_basictype (ffebld_info (l))) + { + case FFEINFO_basictypeLOGICAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + error = ffetarget_convert_logical4_logical1 + (ffebld_cu_ptr_logical4 (u), + ffebld_constant_logical1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + error = ffetarget_convert_logical4_logical2 + (ffebld_cu_ptr_logical4 (u), + ffebld_constant_logical2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + error = ffetarget_convert_logical4_logical3 + (ffebld_cu_ptr_logical4 (u), + ffebld_constant_logical3 (ffebld_conter (l))); + break; +#endif + + default: + assert ("LOGICAL4/LOGICAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_convert_logical4_integer1 + (ffebld_cu_ptr_logical4 (u), + ffebld_constant_integer1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_convert_logical4_integer2 + (ffebld_cu_ptr_logical4 (u), + ffebld_constant_integer2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_convert_logical4_integer3 + (ffebld_cu_ptr_logical4 (u), + ffebld_constant_integer3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_convert_logical4_integer4 + (ffebld_cu_ptr_logical4 (u), + ffebld_constant_integer4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("LOGICAL4/INTEGER bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + error = ffetarget_convert_logical4_character1 + (ffebld_cu_ptr_logical4 (u), + ffebld_constant_character1 (ffebld_conter (l))); + break; + + case FFEINFO_basictypeHOLLERITH: + error = ffetarget_convert_logical4_hollerith + (ffebld_cu_ptr_logical4 (u), + ffebld_constant_hollerith (ffebld_conter (l))); + break; + + case FFEINFO_basictypeTYPELESS: + error = ffetarget_convert_logical4_typeless + (ffebld_cu_ptr_logical4 (u), + ffebld_constant_typeless (ffebld_conter (l))); + break; + + default: + assert ("LOGICAL4 bad type" == NULL); + break; + } + + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logical4_val + (ffebld_cu_val_logical4 (u)), expr); + break; +#endif + + default: + assert ("bad logical kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + sz = FFETARGET_charactersizeNONE; + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + switch (ffeinfo_basictype (ffebld_info (l))) + { + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_convert_real1_integer1 + (ffebld_cu_ptr_real1 (u), + ffebld_constant_integer1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_convert_real1_integer2 + (ffebld_cu_ptr_real1 (u), + ffebld_constant_integer2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_convert_real1_integer3 + (ffebld_cu_ptr_real1 (u), + ffebld_constant_integer3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_convert_real1_integer4 + (ffebld_cu_ptr_real1 (u), + ffebld_constant_integer4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("REAL1/INTEGER bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_real1_real2 + (ffebld_cu_ptr_real1 (u), + ffebld_constant_real2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_real1_real3 + (ffebld_cu_ptr_real1 (u), + ffebld_constant_real3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_real1_real4 + (ffebld_cu_ptr_real1 (u), + ffebld_constant_real4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("REAL1/REAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_real1_complex1 + (ffebld_cu_ptr_real1 (u), + ffebld_constant_complex1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_real1_complex2 + (ffebld_cu_ptr_real1 (u), + ffebld_constant_complex2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_real1_complex3 + (ffebld_cu_ptr_real1 (u), + ffebld_constant_complex3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_real1_complex4 + (ffebld_cu_ptr_real1 (u), + ffebld_constant_complex4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("REAL1/COMPLEX bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + error = ffetarget_convert_real1_character1 + (ffebld_cu_ptr_real1 (u), + ffebld_constant_character1 (ffebld_conter (l))); + break; + + case FFEINFO_basictypeHOLLERITH: + error = ffetarget_convert_real1_hollerith + (ffebld_cu_ptr_real1 (u), + ffebld_constant_hollerith (ffebld_conter (l))); + break; + + case FFEINFO_basictypeTYPELESS: + error = ffetarget_convert_real1_typeless + (ffebld_cu_ptr_real1 (u), + ffebld_constant_typeless (ffebld_conter (l))); + break; + + default: + assert ("REAL1 bad type" == NULL); + break; + } + + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_real1_val + (ffebld_cu_val_real1 (u)), expr); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + switch (ffeinfo_basictype (ffebld_info (l))) + { + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_convert_real2_integer1 + (ffebld_cu_ptr_real2 (u), + ffebld_constant_integer1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_convert_real2_integer2 + (ffebld_cu_ptr_real2 (u), + ffebld_constant_integer2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_convert_real2_integer3 + (ffebld_cu_ptr_real2 (u), + ffebld_constant_integer3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_convert_real2_integer4 + (ffebld_cu_ptr_real2 (u), + ffebld_constant_integer4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("REAL2/INTEGER bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_real2_real1 + (ffebld_cu_ptr_real2 (u), + ffebld_constant_real1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_real2_real3 + (ffebld_cu_ptr_real2 (u), + ffebld_constant_real3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_real2_real4 + (ffebld_cu_ptr_real2 (u), + ffebld_constant_real4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("REAL2/REAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_real2_complex1 + (ffebld_cu_ptr_real2 (u), + ffebld_constant_complex1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_real2_complex2 + (ffebld_cu_ptr_real2 (u), + ffebld_constant_complex2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_real2_complex3 + (ffebld_cu_ptr_real2 (u), + ffebld_constant_complex3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_real2_complex4 + (ffebld_cu_ptr_real2 (u), + ffebld_constant_complex4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("REAL2/COMPLEX bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + error = ffetarget_convert_real2_character1 + (ffebld_cu_ptr_real2 (u), + ffebld_constant_character1 (ffebld_conter (l))); + break; + + case FFEINFO_basictypeHOLLERITH: + error = ffetarget_convert_real2_hollerith + (ffebld_cu_ptr_real2 (u), + ffebld_constant_hollerith (ffebld_conter (l))); + break; + + case FFEINFO_basictypeTYPELESS: + error = ffetarget_convert_real2_typeless + (ffebld_cu_ptr_real2 (u), + ffebld_constant_typeless (ffebld_conter (l))); + break; + + default: + assert ("REAL2 bad type" == NULL); + break; + } + + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_real2_val + (ffebld_cu_val_real2 (u)), expr); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + switch (ffeinfo_basictype (ffebld_info (l))) + { + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_convert_real3_integer1 + (ffebld_cu_ptr_real3 (u), + ffebld_constant_integer1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_convert_real3_integer2 + (ffebld_cu_ptr_real3 (u), + ffebld_constant_integer2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_convert_real3_integer3 + (ffebld_cu_ptr_real3 (u), + ffebld_constant_integer3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_convert_real3_integer4 + (ffebld_cu_ptr_real3 (u), + ffebld_constant_integer4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("REAL3/INTEGER bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_real3_real1 + (ffebld_cu_ptr_real3 (u), + ffebld_constant_real1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_real3_real2 + (ffebld_cu_ptr_real3 (u), + ffebld_constant_real2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_real3_real4 + (ffebld_cu_ptr_real3 (u), + ffebld_constant_real4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("REAL3/REAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_real3_complex1 + (ffebld_cu_ptr_real3 (u), + ffebld_constant_complex1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_real3_complex2 + (ffebld_cu_ptr_real3 (u), + ffebld_constant_complex2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_real3_complex3 + (ffebld_cu_ptr_real3 (u), + ffebld_constant_complex3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_real3_complex4 + (ffebld_cu_ptr_real3 (u), + ffebld_constant_complex4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("REAL3/COMPLEX bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + error = ffetarget_convert_real3_character1 + (ffebld_cu_ptr_real3 (u), + ffebld_constant_character1 (ffebld_conter (l))); + break; + + case FFEINFO_basictypeHOLLERITH: + error = ffetarget_convert_real3_hollerith + (ffebld_cu_ptr_real3 (u), + ffebld_constant_hollerith (ffebld_conter (l))); + break; + + case FFEINFO_basictypeTYPELESS: + error = ffetarget_convert_real3_typeless + (ffebld_cu_ptr_real3 (u), + ffebld_constant_typeless (ffebld_conter (l))); + break; + + default: + assert ("REAL3 bad type" == NULL); + break; + } + + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_real3_val + (ffebld_cu_val_real3 (u)), expr); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + switch (ffeinfo_basictype (ffebld_info (l))) + { + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_convert_real4_integer1 + (ffebld_cu_ptr_real4 (u), + ffebld_constant_integer1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_convert_real4_integer2 + (ffebld_cu_ptr_real4 (u), + ffebld_constant_integer2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_convert_real4_integer3 + (ffebld_cu_ptr_real4 (u), + ffebld_constant_integer3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_convert_real4_integer4 + (ffebld_cu_ptr_real4 (u), + ffebld_constant_integer4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("REAL4/INTEGER bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_real4_real1 + (ffebld_cu_ptr_real4 (u), + ffebld_constant_real1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_real4_real2 + (ffebld_cu_ptr_real4 (u), + ffebld_constant_real2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_real4_real3 + (ffebld_cu_ptr_real4 (u), + ffebld_constant_real3 (ffebld_conter (l))); + break; +#endif + + default: + assert ("REAL4/REAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_real4_complex1 + (ffebld_cu_ptr_real4 (u), + ffebld_constant_complex1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_real4_complex2 + (ffebld_cu_ptr_real4 (u), + ffebld_constant_complex2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_real4_complex3 + (ffebld_cu_ptr_real4 (u), + ffebld_constant_complex3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_real4_complex4 + (ffebld_cu_ptr_real4 (u), + ffebld_constant_complex4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("REAL4/COMPLEX bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + error = ffetarget_convert_real4_character1 + (ffebld_cu_ptr_real4 (u), + ffebld_constant_character1 (ffebld_conter (l))); + break; + + case FFEINFO_basictypeHOLLERITH: + error = ffetarget_convert_real4_hollerith + (ffebld_cu_ptr_real4 (u), + ffebld_constant_hollerith (ffebld_conter (l))); + break; + + case FFEINFO_basictypeTYPELESS: + error = ffetarget_convert_real4_typeless + (ffebld_cu_ptr_real4 (u), + ffebld_constant_typeless (ffebld_conter (l))); + break; + + default: + assert ("REAL4 bad type" == NULL); + break; + } + + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_real4_val + (ffebld_cu_val_real4 (u)), expr); + break; +#endif + + default: + assert ("bad real kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + sz = FFETARGET_charactersizeNONE; + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + switch (ffeinfo_basictype (ffebld_info (l))) + { + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_convert_complex1_integer1 + (ffebld_cu_ptr_complex1 (u), + ffebld_constant_integer1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_convert_complex1_integer2 + (ffebld_cu_ptr_complex1 (u), + ffebld_constant_integer2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_convert_complex1_integer3 + (ffebld_cu_ptr_complex1 (u), + ffebld_constant_integer3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_convert_complex1_integer4 + (ffebld_cu_ptr_complex1 (u), + ffebld_constant_integer4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("COMPLEX1/INTEGER bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_complex1_real1 + (ffebld_cu_ptr_complex1 (u), + ffebld_constant_real1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_complex1_real2 + (ffebld_cu_ptr_complex1 (u), + ffebld_constant_real2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_complex1_real3 + (ffebld_cu_ptr_complex1 (u), + ffebld_constant_real3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_complex1_real4 + (ffebld_cu_ptr_complex1 (u), + ffebld_constant_real4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("COMPLEX1/REAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_complex1_complex2 + (ffebld_cu_ptr_complex1 (u), + ffebld_constant_complex2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_complex1_complex3 + (ffebld_cu_ptr_complex1 (u), + ffebld_constant_complex3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_complex1_complex4 + (ffebld_cu_ptr_complex1 (u), + ffebld_constant_complex4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("COMPLEX1/COMPLEX bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + error = ffetarget_convert_complex1_character1 + (ffebld_cu_ptr_complex1 (u), + ffebld_constant_character1 (ffebld_conter (l))); + break; + + case FFEINFO_basictypeHOLLERITH: + error = ffetarget_convert_complex1_hollerith + (ffebld_cu_ptr_complex1 (u), + ffebld_constant_hollerith (ffebld_conter (l))); + break; + + case FFEINFO_basictypeTYPELESS: + error = ffetarget_convert_complex1_typeless + (ffebld_cu_ptr_complex1 (u), + ffebld_constant_typeless (ffebld_conter (l))); + break; + + default: + assert ("COMPLEX1 bad type" == NULL); + break; + } + + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_complex1_val + (ffebld_cu_val_complex1 (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + switch (ffeinfo_basictype (ffebld_info (l))) + { + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_convert_complex2_integer1 + (ffebld_cu_ptr_complex2 (u), + ffebld_constant_integer1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_convert_complex2_integer2 + (ffebld_cu_ptr_complex2 (u), + ffebld_constant_integer2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_convert_complex2_integer3 + (ffebld_cu_ptr_complex2 (u), + ffebld_constant_integer3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_convert_complex2_integer4 + (ffebld_cu_ptr_complex2 (u), + ffebld_constant_integer4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("COMPLEX2/INTEGER bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_complex2_real1 + (ffebld_cu_ptr_complex2 (u), + ffebld_constant_real1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_complex2_real2 + (ffebld_cu_ptr_complex2 (u), + ffebld_constant_real2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_complex2_real3 + (ffebld_cu_ptr_complex2 (u), + ffebld_constant_real3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_complex2_real4 + (ffebld_cu_ptr_complex2 (u), + ffebld_constant_real4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("COMPLEX2/REAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_complex2_complex1 + (ffebld_cu_ptr_complex2 (u), + ffebld_constant_complex1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_complex2_complex3 + (ffebld_cu_ptr_complex2 (u), + ffebld_constant_complex3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_complex2_complex4 + (ffebld_cu_ptr_complex2 (u), + ffebld_constant_complex4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("COMPLEX2/COMPLEX bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + error = ffetarget_convert_complex2_character1 + (ffebld_cu_ptr_complex2 (u), + ffebld_constant_character1 (ffebld_conter (l))); + break; + + case FFEINFO_basictypeHOLLERITH: + error = ffetarget_convert_complex2_hollerith + (ffebld_cu_ptr_complex2 (u), + ffebld_constant_hollerith (ffebld_conter (l))); + break; + + case FFEINFO_basictypeTYPELESS: + error = ffetarget_convert_complex2_typeless + (ffebld_cu_ptr_complex2 (u), + ffebld_constant_typeless (ffebld_conter (l))); + break; + + default: + assert ("COMPLEX2 bad type" == NULL); + break; + } + + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_complex2_val + (ffebld_cu_val_complex2 (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + switch (ffeinfo_basictype (ffebld_info (l))) + { + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_convert_complex3_integer1 + (ffebld_cu_ptr_complex3 (u), + ffebld_constant_integer1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_convert_complex3_integer2 + (ffebld_cu_ptr_complex3 (u), + ffebld_constant_integer2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_convert_complex3_integer3 + (ffebld_cu_ptr_complex3 (u), + ffebld_constant_integer3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_convert_complex3_integer4 + (ffebld_cu_ptr_complex3 (u), + ffebld_constant_integer4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("COMPLEX3/INTEGER bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_complex3_real1 + (ffebld_cu_ptr_complex3 (u), + ffebld_constant_real1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_complex3_real2 + (ffebld_cu_ptr_complex3 (u), + ffebld_constant_real2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_complex3_real3 + (ffebld_cu_ptr_complex3 (u), + ffebld_constant_real3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_complex3_real4 + (ffebld_cu_ptr_complex3 (u), + ffebld_constant_real4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("COMPLEX3/REAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_complex3_complex1 + (ffebld_cu_ptr_complex3 (u), + ffebld_constant_complex1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_complex3_complex2 + (ffebld_cu_ptr_complex3 (u), + ffebld_constant_complex2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_complex3_complex4 + (ffebld_cu_ptr_complex3 (u), + ffebld_constant_complex4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("COMPLEX3/COMPLEX bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + error = ffetarget_convert_complex3_character1 + (ffebld_cu_ptr_complex3 (u), + ffebld_constant_character1 (ffebld_conter (l))); + break; + + case FFEINFO_basictypeHOLLERITH: + error = ffetarget_convert_complex3_hollerith + (ffebld_cu_ptr_complex3 (u), + ffebld_constant_hollerith (ffebld_conter (l))); + break; + + case FFEINFO_basictypeTYPELESS: + error = ffetarget_convert_complex3_typeless + (ffebld_cu_ptr_complex3 (u), + ffebld_constant_typeless (ffebld_conter (l))); + break; + + default: + assert ("COMPLEX3 bad type" == NULL); + break; + } + + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_complex3_val + (ffebld_cu_val_complex3 (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + switch (ffeinfo_basictype (ffebld_info (l))) + { + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_convert_complex4_integer1 + (ffebld_cu_ptr_complex4 (u), + ffebld_constant_integer1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_convert_complex4_integer2 + (ffebld_cu_ptr_complex4 (u), + ffebld_constant_integer2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_convert_complex4_integer3 + (ffebld_cu_ptr_complex4 (u), + ffebld_constant_integer3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_convert_complex4_integer4 + (ffebld_cu_ptr_complex4 (u), + ffebld_constant_integer4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("COMPLEX4/INTEGER bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_complex4_real1 + (ffebld_cu_ptr_complex4 (u), + ffebld_constant_real1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_complex4_real2 + (ffebld_cu_ptr_complex4 (u), + ffebld_constant_real2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_complex4_real3 + (ffebld_cu_ptr_complex4 (u), + ffebld_constant_real3 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_convert_complex4_real4 + (ffebld_cu_ptr_complex4 (u), + ffebld_constant_real4 (ffebld_conter (l))); + break; +#endif + + default: + assert ("COMPLEX4/REAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_convert_complex4_complex1 + (ffebld_cu_ptr_complex4 (u), + ffebld_constant_complex1 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_convert_complex4_complex2 + (ffebld_cu_ptr_complex4 (u), + ffebld_constant_complex2 (ffebld_conter (l))); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_convert_complex4_complex3 + (ffebld_cu_ptr_complex4 (u), + ffebld_constant_complex3 (ffebld_conter (l))); + break; +#endif + + default: + assert ("COMPLEX4/COMPLEX bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + error = ffetarget_convert_complex4_character1 + (ffebld_cu_ptr_complex4 (u), + ffebld_constant_character1 (ffebld_conter (l))); + break; + + case FFEINFO_basictypeHOLLERITH: + error = ffetarget_convert_complex4_hollerith + (ffebld_cu_ptr_complex4 (u), + ffebld_constant_hollerith (ffebld_conter (l))); + break; + + case FFEINFO_basictypeTYPELESS: + error = ffetarget_convert_complex4_typeless + (ffebld_cu_ptr_complex4 (u), + ffebld_constant_typeless (ffebld_conter (l))); + break; + + default: + assert ("COMPLEX4 bad type" == NULL); + break; + } + + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_complex4_val + (ffebld_cu_val_complex4 (u)), expr); + break; +#endif + + default: + assert ("bad complex kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE) + return expr; + kt = ffeinfo_kindtype (ffebld_info (expr)); + switch (kt) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeCHARACTER1: + switch (ffeinfo_basictype (ffebld_info (l))) + { + case FFEINFO_basictypeCHARACTER: + if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE) + return expr; + assert (kt == ffeinfo_kindtype (ffebld_info (l))); + assert (sz2 == ffetarget_length_character1 + (ffebld_constant_character1 + (ffebld_conter (l)))); + error + = ffetarget_convert_character1_character1 + (ffebld_cu_ptr_character1 (u), sz, + ffebld_constant_character1 (ffebld_conter (l)), + ffebld_constant_pool ()); + break; + + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error + = ffetarget_convert_character1_integer1 + (ffebld_cu_ptr_character1 (u), + sz, + ffebld_constant_integer1 (ffebld_conter (l)), + ffebld_constant_pool ()); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error + = ffetarget_convert_character1_integer2 + (ffebld_cu_ptr_character1 (u), + sz, + ffebld_constant_integer2 (ffebld_conter (l)), + ffebld_constant_pool ()); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error + = ffetarget_convert_character1_integer3 + (ffebld_cu_ptr_character1 (u), + sz, + ffebld_constant_integer3 (ffebld_conter (l)), + ffebld_constant_pool ()); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error + = ffetarget_convert_character1_integer4 + (ffebld_cu_ptr_character1 (u), + sz, + ffebld_constant_integer4 (ffebld_conter (l)), + ffebld_constant_pool ()); + break; +#endif + + default: + assert ("CHARACTER1/INTEGER bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + switch (ffeinfo_kindtype (ffebld_info (l))) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + error + = ffetarget_convert_character1_logical1 + (ffebld_cu_ptr_character1 (u), + sz, + ffebld_constant_logical1 (ffebld_conter (l)), + ffebld_constant_pool ()); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + error + = ffetarget_convert_character1_logical2 + (ffebld_cu_ptr_character1 (u), + sz, + ffebld_constant_logical2 (ffebld_conter (l)), + ffebld_constant_pool ()); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + error + = ffetarget_convert_character1_logical3 + (ffebld_cu_ptr_character1 (u), + sz, + ffebld_constant_logical3 (ffebld_conter (l)), + ffebld_constant_pool ()); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + error + = ffetarget_convert_character1_logical4 + (ffebld_cu_ptr_character1 (u), + sz, + ffebld_constant_logical4 (ffebld_conter (l)), + ffebld_constant_pool ()); + break; +#endif + + default: + assert ("CHARACTER1/LOGICAL bad source kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeHOLLERITH: + error + = ffetarget_convert_character1_hollerith + (ffebld_cu_ptr_character1 (u), + sz, + ffebld_constant_hollerith (ffebld_conter (l)), + ffebld_constant_pool ()); + break; + + case FFEINFO_basictypeTYPELESS: + error + = ffetarget_convert_character1_typeless + (ffebld_cu_ptr_character1 (u), + sz, + ffebld_constant_typeless (ffebld_conter (l)), + ffebld_constant_pool ()); + break; + + default: + assert ("CHARACTER1 bad type" == NULL); + } + + expr + = ffebld_new_conter_with_orig + (ffebld_constant_new_character1_val + (ffebld_cu_val_character1 (u)), + expr); + break; +#endif + + default: + assert ("bad character kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (bt, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + sz)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + assert (t != NULL); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_paren -- Collapse paren expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_paren(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED) +{ + ffebld r; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffetargetCharacterSize len; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + r = ffebld_left (expr); + + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + bt = ffeinfo_basictype (ffebld_info (r)); + kt = ffeinfo_kindtype (ffebld_info (r)); + len = ffebld_size (r); + + expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)), + expr); + + ffebld_set_info (expr, ffeinfo_new + (bt, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + len)); + + return expr; +} + +/* ffeexpr_collapse_uplus -- Collapse uplus expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_uplus(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED) +{ + ffebld r; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffetargetCharacterSize len; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + r = ffebld_left (expr); + + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + bt = ffeinfo_basictype (ffebld_info (r)); + kt = ffeinfo_kindtype (ffebld_info (r)); + len = ffebld_size (r); + + expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)), + expr); + + ffebld_set_info (expr, ffeinfo_new + (bt, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + len)); + + return expr; +} + +/* ffeexpr_collapse_uminus -- Collapse uminus expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_uminus(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_uminus (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld r; + ffebldConstantUnion u; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + r = ffebld_left (expr); + + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + switch (bt = ffeinfo_basictype (ffebld_info (expr))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u), + ffebld_constant_integer1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val + (ffebld_cu_val_integer1 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u), + ffebld_constant_integer2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val + (ffebld_cu_val_integer2 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u), + ffebld_constant_integer3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val + (ffebld_cu_val_integer3 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u), + ffebld_constant_integer4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val + (ffebld_cu_val_integer4 (u)), expr); + break; +#endif + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u), + ffebld_constant_real1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val + (ffebld_cu_val_real1 (u)), expr); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u), + ffebld_constant_real2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val + (ffebld_cu_val_real2 (u)), expr); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u), + ffebld_constant_real3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val + (ffebld_cu_val_real3 (u)), expr); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_uminus_real4 (ffebld_cu_ptr_real4 (u), + ffebld_constant_real4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val + (ffebld_cu_val_real4 (u)), expr); + break; +#endif + + default: + assert ("bad real kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u), + ffebld_constant_complex1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val + (ffebld_cu_val_complex1 (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u), + ffebld_constant_complex2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val + (ffebld_cu_val_complex2 (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u), + ffebld_constant_complex3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val + (ffebld_cu_val_complex3 (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_uminus_complex4 (ffebld_cu_ptr_complex4 (u), + ffebld_constant_complex4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val + (ffebld_cu_val_complex4 (u)), expr); + break; +#endif + + default: + assert ("bad complex kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (bt, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_not -- Collapse not expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_not(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_not (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld r; + ffebldConstantUnion u; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + r = ffebld_left (expr); + + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + switch (bt = ffeinfo_basictype (ffebld_info (expr))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u), + ffebld_constant_integer1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val + (ffebld_cu_val_integer1 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u), + ffebld_constant_integer2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val + (ffebld_cu_val_integer2 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u), + ffebld_constant_integer3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val + (ffebld_cu_val_integer3 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u), + ffebld_constant_integer4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val + (ffebld_cu_val_integer4 (u)), expr); + break; +#endif + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u), + ffebld_constant_logical1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val + (ffebld_cu_val_logical1 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u), + ffebld_constant_logical2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val + (ffebld_cu_val_logical2 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u), + ffebld_constant_logical3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val + (ffebld_cu_val_logical3 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u), + ffebld_constant_logical4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val + (ffebld_cu_val_logical4 (u)), expr); + break; +#endif + + default: + assert ("bad logical kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (bt, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_add -- Collapse add expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_add(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_add (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebld r; + ffebldConstantUnion u; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + r = ffebld_right (expr); + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + switch (bt = ffeinfo_basictype (ffebld_info (expr))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u), + ffebld_constant_integer1 (ffebld_conter (l)), + ffebld_constant_integer1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val + (ffebld_cu_val_integer1 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u), + ffebld_constant_integer2 (ffebld_conter (l)), + ffebld_constant_integer2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val + (ffebld_cu_val_integer2 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u), + ffebld_constant_integer3 (ffebld_conter (l)), + ffebld_constant_integer3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val + (ffebld_cu_val_integer3 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u), + ffebld_constant_integer4 (ffebld_conter (l)), + ffebld_constant_integer4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val + (ffebld_cu_val_integer4 (u)), expr); + break; +#endif + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u), + ffebld_constant_real1 (ffebld_conter (l)), + ffebld_constant_real1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val + (ffebld_cu_val_real1 (u)), expr); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u), + ffebld_constant_real2 (ffebld_conter (l)), + ffebld_constant_real2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val + (ffebld_cu_val_real2 (u)), expr); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u), + ffebld_constant_real3 (ffebld_conter (l)), + ffebld_constant_real3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val + (ffebld_cu_val_real3 (u)), expr); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_add_real4 (ffebld_cu_ptr_real4 (u), + ffebld_constant_real4 (ffebld_conter (l)), + ffebld_constant_real4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val + (ffebld_cu_val_real4 (u)), expr); + break; +#endif + + default: + assert ("bad real kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u), + ffebld_constant_complex1 (ffebld_conter (l)), + ffebld_constant_complex1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val + (ffebld_cu_val_complex1 (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u), + ffebld_constant_complex2 (ffebld_conter (l)), + ffebld_constant_complex2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val + (ffebld_cu_val_complex2 (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u), + ffebld_constant_complex3 (ffebld_conter (l)), + ffebld_constant_complex3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val + (ffebld_cu_val_complex3 (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_add_complex4 (ffebld_cu_ptr_complex4 (u), + ffebld_constant_complex4 (ffebld_conter (l)), + ffebld_constant_complex4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val + (ffebld_cu_val_complex4 (u)), expr); + break; +#endif + + default: + assert ("bad complex kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (bt, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_subtract -- Collapse subtract expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_subtract(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_subtract (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebld r; + ffebldConstantUnion u; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + r = ffebld_right (expr); + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + switch (bt = ffeinfo_basictype (ffebld_info (expr))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u), + ffebld_constant_integer1 (ffebld_conter (l)), + ffebld_constant_integer1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val + (ffebld_cu_val_integer1 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u), + ffebld_constant_integer2 (ffebld_conter (l)), + ffebld_constant_integer2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val + (ffebld_cu_val_integer2 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u), + ffebld_constant_integer3 (ffebld_conter (l)), + ffebld_constant_integer3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val + (ffebld_cu_val_integer3 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u), + ffebld_constant_integer4 (ffebld_conter (l)), + ffebld_constant_integer4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val + (ffebld_cu_val_integer4 (u)), expr); + break; +#endif + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u), + ffebld_constant_real1 (ffebld_conter (l)), + ffebld_constant_real1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val + (ffebld_cu_val_real1 (u)), expr); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u), + ffebld_constant_real2 (ffebld_conter (l)), + ffebld_constant_real2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val + (ffebld_cu_val_real2 (u)), expr); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u), + ffebld_constant_real3 (ffebld_conter (l)), + ffebld_constant_real3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val + (ffebld_cu_val_real3 (u)), expr); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_subtract_real4 (ffebld_cu_ptr_real4 (u), + ffebld_constant_real4 (ffebld_conter (l)), + ffebld_constant_real4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val + (ffebld_cu_val_real4 (u)), expr); + break; +#endif + + default: + assert ("bad real kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u), + ffebld_constant_complex1 (ffebld_conter (l)), + ffebld_constant_complex1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val + (ffebld_cu_val_complex1 (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u), + ffebld_constant_complex2 (ffebld_conter (l)), + ffebld_constant_complex2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val + (ffebld_cu_val_complex2 (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u), + ffebld_constant_complex3 (ffebld_conter (l)), + ffebld_constant_complex3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val + (ffebld_cu_val_complex3 (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_subtract_complex4 (ffebld_cu_ptr_complex4 (u), + ffebld_constant_complex4 (ffebld_conter (l)), + ffebld_constant_complex4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val + (ffebld_cu_val_complex4 (u)), expr); + break; +#endif + + default: + assert ("bad complex kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (bt, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_multiply -- Collapse multiply expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_multiply(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_multiply (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebld r; + ffebldConstantUnion u; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + r = ffebld_right (expr); + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + switch (bt = ffeinfo_basictype (ffebld_info (expr))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u), + ffebld_constant_integer1 (ffebld_conter (l)), + ffebld_constant_integer1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val + (ffebld_cu_val_integer1 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u), + ffebld_constant_integer2 (ffebld_conter (l)), + ffebld_constant_integer2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val + (ffebld_cu_val_integer2 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u), + ffebld_constant_integer3 (ffebld_conter (l)), + ffebld_constant_integer3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val + (ffebld_cu_val_integer3 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u), + ffebld_constant_integer4 (ffebld_conter (l)), + ffebld_constant_integer4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val + (ffebld_cu_val_integer4 (u)), expr); + break; +#endif + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u), + ffebld_constant_real1 (ffebld_conter (l)), + ffebld_constant_real1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val + (ffebld_cu_val_real1 (u)), expr); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u), + ffebld_constant_real2 (ffebld_conter (l)), + ffebld_constant_real2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val + (ffebld_cu_val_real2 (u)), expr); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u), + ffebld_constant_real3 (ffebld_conter (l)), + ffebld_constant_real3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val + (ffebld_cu_val_real3 (u)), expr); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_multiply_real4 (ffebld_cu_ptr_real4 (u), + ffebld_constant_real4 (ffebld_conter (l)), + ffebld_constant_real4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val + (ffebld_cu_val_real4 (u)), expr); + break; +#endif + + default: + assert ("bad real kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u), + ffebld_constant_complex1 (ffebld_conter (l)), + ffebld_constant_complex1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val + (ffebld_cu_val_complex1 (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u), + ffebld_constant_complex2 (ffebld_conter (l)), + ffebld_constant_complex2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val + (ffebld_cu_val_complex2 (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u), + ffebld_constant_complex3 (ffebld_conter (l)), + ffebld_constant_complex3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val + (ffebld_cu_val_complex3 (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_multiply_complex4 (ffebld_cu_ptr_complex4 (u), + ffebld_constant_complex4 (ffebld_conter (l)), + ffebld_constant_complex4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val + (ffebld_cu_val_complex4 (u)), expr); + break; +#endif + + default: + assert ("bad complex kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (bt, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_divide -- Collapse divide expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_divide(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_divide (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebld r; + ffebldConstantUnion u; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + r = ffebld_right (expr); + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + switch (bt = ffeinfo_basictype (ffebld_info (expr))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u), + ffebld_constant_integer1 (ffebld_conter (l)), + ffebld_constant_integer1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val + (ffebld_cu_val_integer1 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u), + ffebld_constant_integer2 (ffebld_conter (l)), + ffebld_constant_integer2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val + (ffebld_cu_val_integer2 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u), + ffebld_constant_integer3 (ffebld_conter (l)), + ffebld_constant_integer3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val + (ffebld_cu_val_integer3 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u), + ffebld_constant_integer4 (ffebld_conter (l)), + ffebld_constant_integer4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val + (ffebld_cu_val_integer4 (u)), expr); + break; +#endif + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u), + ffebld_constant_real1 (ffebld_conter (l)), + ffebld_constant_real1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val + (ffebld_cu_val_real1 (u)), expr); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u), + ffebld_constant_real2 (ffebld_conter (l)), + ffebld_constant_real2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val + (ffebld_cu_val_real2 (u)), expr); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u), + ffebld_constant_real3 (ffebld_conter (l)), + ffebld_constant_real3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val + (ffebld_cu_val_real3 (u)), expr); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_divide_real4 (ffebld_cu_ptr_real4 (u), + ffebld_constant_real4 (ffebld_conter (l)), + ffebld_constant_real4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val + (ffebld_cu_val_real4 (u)), expr); + break; +#endif + + default: + assert ("bad real kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u), + ffebld_constant_complex1 (ffebld_conter (l)), + ffebld_constant_complex1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val + (ffebld_cu_val_complex1 (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u), + ffebld_constant_complex2 (ffebld_conter (l)), + ffebld_constant_complex2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val + (ffebld_cu_val_complex2 (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u), + ffebld_constant_complex3 (ffebld_conter (l)), + ffebld_constant_complex3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val + (ffebld_cu_val_complex3 (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_divide_complex4 (ffebld_cu_ptr_complex4 (u), + ffebld_constant_complex4 (ffebld_conter (l)), + ffebld_constant_complex4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val + (ffebld_cu_val_complex4 (u)), expr); + break; +#endif + + default: + assert ("bad complex kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (bt, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_power -- Collapse power expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_power(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_power (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebld r; + ffebldConstantUnion u; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + r = ffebld_right (expr); + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER) + || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT)) + return expr; + + switch (bt = ffeinfo_basictype (ffebld_info (expr))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { + case FFEINFO_kindtypeINTEGERDEFAULT: + error = ffetarget_power_integerdefault_integerdefault + (ffebld_cu_ptr_integerdefault (u), + ffebld_constant_integerdefault (ffebld_conter (l)), + ffebld_constant_integerdefault (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_integerdefault_val + (ffebld_cu_val_integerdefault (u)), expr); + break; + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { + case FFEINFO_kindtypeREALDEFAULT: + error = ffetarget_power_realdefault_integerdefault + (ffebld_cu_ptr_realdefault (u), + ffebld_constant_realdefault (ffebld_conter (l)), + ffebld_constant_integerdefault (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_realdefault_val + (ffebld_cu_val_realdefault (u)), expr); + break; + + case FFEINFO_kindtypeREALDOUBLE: + error = ffetarget_power_realdouble_integerdefault + (ffebld_cu_ptr_realdouble (u), + ffebld_constant_realdouble (ffebld_conter (l)), + ffebld_constant_integerdefault (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_realdouble_val + (ffebld_cu_val_realdouble (u)), expr); + break; + +#if FFETARGET_okREALQUAD + case FFEINFO_kindtypeREALQUAD: + error = ffetarget_power_realquad_integerdefault + (ffebld_cu_ptr_realquad (u), + ffebld_constant_realquad (ffebld_conter (l)), + ffebld_constant_integerdefault (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_realquad_val + (ffebld_cu_val_realquad (u)), expr); + break; +#endif + default: + assert ("bad real kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { + case FFEINFO_kindtypeREALDEFAULT: + error = ffetarget_power_complexdefault_integerdefault + (ffebld_cu_ptr_complexdefault (u), + ffebld_constant_complexdefault (ffebld_conter (l)), + ffebld_constant_integerdefault (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_complexdefault_val + (ffebld_cu_val_complexdefault (u)), expr); + break; + +#if FFETARGET_okCOMPLEXDOUBLE + case FFEINFO_kindtypeREALDOUBLE: + error = ffetarget_power_complexdouble_integerdefault + (ffebld_cu_ptr_complexdouble (u), + ffebld_constant_complexdouble (ffebld_conter (l)), + ffebld_constant_integerdefault (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_complexdouble_val + (ffebld_cu_val_complexdouble (u)), expr); + break; +#endif + +#if FFETARGET_okCOMPLEXQUAD + case FFEINFO_kindtypeREALQUAD: + error = ffetarget_power_complexquad_integerdefault + (ffebld_cu_ptr_complexquad (u), + ffebld_constant_complexquad (ffebld_conter (l)), + ffebld_constant_integerdefault (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_complexquad_val + (ffebld_cu_val_complexquad (u)), expr); + break; +#endif + + default: + assert ("bad complex kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (bt, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_concatenate -- Collapse concatenate expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_concatenate(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebld r; + ffebldConstantUnion u; + ffeinfoKindtype kt; + ffetargetCharacterSize len; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + r = ffebld_right (expr); + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + switch (ffeinfo_basictype (ffebld_info (expr))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeCHARACTER: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeCHARACTER1: + error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u), + ffebld_constant_character1 (ffebld_conter (l)), + ffebld_constant_character1 (ffebld_conter (r)), + ffebld_constant_pool (), &len); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val + (ffebld_cu_val_character1 (u)), expr); + break; +#endif + +#if FFETARGET_okCHARACTER2 + case FFEINFO_kindtypeCHARACTER2: + error = ffetarget_concatenate_character2 (ffebld_cu_ptr_character2 (u), + ffebld_constant_character2 (ffebld_conter (l)), + ffebld_constant_character2 (ffebld_conter (r)), + ffebld_constant_pool (), &len); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val + (ffebld_cu_val_character2 (u)), expr); + break; +#endif + +#if FFETARGET_okCHARACTER3 + case FFEINFO_kindtypeCHARACTER3: + error = ffetarget_concatenate_character3 (ffebld_cu_ptr_character3 (u), + ffebld_constant_character3 (ffebld_conter (l)), + ffebld_constant_character3 (ffebld_conter (r)), + ffebld_constant_pool (), &len); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val + (ffebld_cu_val_character3 (u)), expr); + break; +#endif + +#if FFETARGET_okCHARACTER4 + case FFEINFO_kindtypeCHARACTER4: + error = ffetarget_concatenate_character4 (ffebld_cu_ptr_character4 (u), + ffebld_constant_character4 (ffebld_conter (l)), + ffebld_constant_character4 (ffebld_conter (r)), + ffebld_constant_pool (), &len); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val + (ffebld_cu_val_character4 (u)), expr); + break; +#endif + + default: + assert ("bad character kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (FFEINFO_basictypeCHARACTER, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + len)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_eq -- Collapse eq expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_eq(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_eq (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebld r; + bool val; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + r = ffebld_right (expr); + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_eq_integer1 (&val, + ffebld_constant_integer1 (ffebld_conter (l)), + ffebld_constant_integer1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_eq_integer2 (&val, + ffebld_constant_integer2 (ffebld_conter (l)), + ffebld_constant_integer2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_eq_integer3 (&val, + ffebld_constant_integer3 (ffebld_conter (l)), + ffebld_constant_integer3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_eq_integer4 (&val, + ffebld_constant_integer4 (ffebld_conter (l)), + ffebld_constant_integer4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_eq_real1 (&val, + ffebld_constant_real1 (ffebld_conter (l)), + ffebld_constant_real1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_eq_real2 (&val, + ffebld_constant_real2 (ffebld_conter (l)), + ffebld_constant_real2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_eq_real3 (&val, + ffebld_constant_real3 (ffebld_conter (l)), + ffebld_constant_real3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_eq_real4 (&val, + ffebld_constant_real4 (ffebld_conter (l)), + ffebld_constant_real4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad real kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_eq_complex1 (&val, + ffebld_constant_complex1 (ffebld_conter (l)), + ffebld_constant_complex1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_eq_complex2 (&val, + ffebld_constant_complex2 (ffebld_conter (l)), + ffebld_constant_complex2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_eq_complex3 (&val, + ffebld_constant_complex3 (ffebld_conter (l)), + ffebld_constant_complex3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_eq_complex4 (&val, + ffebld_constant_complex4 (ffebld_conter (l)), + ffebld_constant_complex4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad complex kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeCHARACTER1: + error = ffetarget_eq_character1 (&val, + ffebld_constant_character1 (ffebld_conter (l)), + ffebld_constant_character1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCHARACTER2 + case FFEINFO_kindtypeCHARACTER2: + error = ffetarget_eq_character2 (&val, + ffebld_constant_character2 (ffebld_conter (l)), + ffebld_constant_character2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCHARACTER3 + case FFEINFO_kindtypeCHARACTER3: + error = ffetarget_eq_character3 (&val, + ffebld_constant_character3 (ffebld_conter (l)), + ffebld_constant_character3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCHARACTER4 + case FFEINFO_kindtypeCHARACTER4: + error = ffetarget_eq_character4 (&val, + ffebld_constant_character4 (ffebld_conter (l)), + ffebld_constant_character4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad character kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_ne -- Collapse ne expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_ne(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_ne (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebld r; + bool val; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + r = ffebld_right (expr); + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_ne_integer1 (&val, + ffebld_constant_integer1 (ffebld_conter (l)), + ffebld_constant_integer1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_ne_integer2 (&val, + ffebld_constant_integer2 (ffebld_conter (l)), + ffebld_constant_integer2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_ne_integer3 (&val, + ffebld_constant_integer3 (ffebld_conter (l)), + ffebld_constant_integer3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_ne_integer4 (&val, + ffebld_constant_integer4 (ffebld_conter (l)), + ffebld_constant_integer4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_ne_real1 (&val, + ffebld_constant_real1 (ffebld_conter (l)), + ffebld_constant_real1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_ne_real2 (&val, + ffebld_constant_real2 (ffebld_conter (l)), + ffebld_constant_real2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_ne_real3 (&val, + ffebld_constant_real3 (ffebld_conter (l)), + ffebld_constant_real3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_ne_real4 (&val, + ffebld_constant_real4 (ffebld_conter (l)), + ffebld_constant_real4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad real kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCOMPLEX: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_ne_complex1 (&val, + ffebld_constant_complex1 (ffebld_conter (l)), + ffebld_constant_complex1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_ne_complex2 (&val, + ffebld_constant_complex2 (ffebld_conter (l)), + ffebld_constant_complex2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_ne_complex3 (&val, + ffebld_constant_complex3 (ffebld_conter (l)), + ffebld_constant_complex3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_ne_complex4 (&val, + ffebld_constant_complex4 (ffebld_conter (l)), + ffebld_constant_complex4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad complex kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeCHARACTER1: + error = ffetarget_ne_character1 (&val, + ffebld_constant_character1 (ffebld_conter (l)), + ffebld_constant_character1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCHARACTER2 + case FFEINFO_kindtypeCHARACTER2: + error = ffetarget_ne_character2 (&val, + ffebld_constant_character2 (ffebld_conter (l)), + ffebld_constant_character2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCHARACTER3 + case FFEINFO_kindtypeCHARACTER3: + error = ffetarget_ne_character3 (&val, + ffebld_constant_character3 (ffebld_conter (l)), + ffebld_constant_character3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCHARACTER4 + case FFEINFO_kindtypeCHARACTER4: + error = ffetarget_ne_character4 (&val, + ffebld_constant_character4 (ffebld_conter (l)), + ffebld_constant_character4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad character kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_ge -- Collapse ge expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_ge(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_ge (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebld r; + bool val; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + r = ffebld_right (expr); + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_ge_integer1 (&val, + ffebld_constant_integer1 (ffebld_conter (l)), + ffebld_constant_integer1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_ge_integer2 (&val, + ffebld_constant_integer2 (ffebld_conter (l)), + ffebld_constant_integer2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_ge_integer3 (&val, + ffebld_constant_integer3 (ffebld_conter (l)), + ffebld_constant_integer3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_ge_integer4 (&val, + ffebld_constant_integer4 (ffebld_conter (l)), + ffebld_constant_integer4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_ge_real1 (&val, + ffebld_constant_real1 (ffebld_conter (l)), + ffebld_constant_real1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_ge_real2 (&val, + ffebld_constant_real2 (ffebld_conter (l)), + ffebld_constant_real2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_ge_real3 (&val, + ffebld_constant_real3 (ffebld_conter (l)), + ffebld_constant_real3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_ge_real4 (&val, + ffebld_constant_real4 (ffebld_conter (l)), + ffebld_constant_real4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad real kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeCHARACTER1: + error = ffetarget_ge_character1 (&val, + ffebld_constant_character1 (ffebld_conter (l)), + ffebld_constant_character1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCHARACTER2 + case FFEINFO_kindtypeCHARACTER2: + error = ffetarget_ge_character2 (&val, + ffebld_constant_character2 (ffebld_conter (l)), + ffebld_constant_character2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCHARACTER3 + case FFEINFO_kindtypeCHARACTER3: + error = ffetarget_ge_character3 (&val, + ffebld_constant_character3 (ffebld_conter (l)), + ffebld_constant_character3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCHARACTER4 + case FFEINFO_kindtypeCHARACTER4: + error = ffetarget_ge_character4 (&val, + ffebld_constant_character4 (ffebld_conter (l)), + ffebld_constant_character4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad character kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_gt -- Collapse gt expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_gt(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_gt (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebld r; + bool val; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + r = ffebld_right (expr); + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_gt_integer1 (&val, + ffebld_constant_integer1 (ffebld_conter (l)), + ffebld_constant_integer1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_gt_integer2 (&val, + ffebld_constant_integer2 (ffebld_conter (l)), + ffebld_constant_integer2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_gt_integer3 (&val, + ffebld_constant_integer3 (ffebld_conter (l)), + ffebld_constant_integer3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_gt_integer4 (&val, + ffebld_constant_integer4 (ffebld_conter (l)), + ffebld_constant_integer4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_gt_real1 (&val, + ffebld_constant_real1 (ffebld_conter (l)), + ffebld_constant_real1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_gt_real2 (&val, + ffebld_constant_real2 (ffebld_conter (l)), + ffebld_constant_real2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_gt_real3 (&val, + ffebld_constant_real3 (ffebld_conter (l)), + ffebld_constant_real3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_gt_real4 (&val, + ffebld_constant_real4 (ffebld_conter (l)), + ffebld_constant_real4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad real kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeCHARACTER1: + error = ffetarget_gt_character1 (&val, + ffebld_constant_character1 (ffebld_conter (l)), + ffebld_constant_character1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCHARACTER2 + case FFEINFO_kindtypeCHARACTER2: + error = ffetarget_gt_character2 (&val, + ffebld_constant_character2 (ffebld_conter (l)), + ffebld_constant_character2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCHARACTER3 + case FFEINFO_kindtypeCHARACTER3: + error = ffetarget_gt_character3 (&val, + ffebld_constant_character3 (ffebld_conter (l)), + ffebld_constant_character3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCHARACTER4 + case FFEINFO_kindtypeCHARACTER4: + error = ffetarget_gt_character4 (&val, + ffebld_constant_character4 (ffebld_conter (l)), + ffebld_constant_character4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad character kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_le -- Collapse le expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_le(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_le (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebld r; + bool val; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + r = ffebld_right (expr); + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_le_integer1 (&val, + ffebld_constant_integer1 (ffebld_conter (l)), + ffebld_constant_integer1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_le_integer2 (&val, + ffebld_constant_integer2 (ffebld_conter (l)), + ffebld_constant_integer2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_le_integer3 (&val, + ffebld_constant_integer3 (ffebld_conter (l)), + ffebld_constant_integer3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_le_integer4 (&val, + ffebld_constant_integer4 (ffebld_conter (l)), + ffebld_constant_integer4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_le_real1 (&val, + ffebld_constant_real1 (ffebld_conter (l)), + ffebld_constant_real1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_le_real2 (&val, + ffebld_constant_real2 (ffebld_conter (l)), + ffebld_constant_real2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_le_real3 (&val, + ffebld_constant_real3 (ffebld_conter (l)), + ffebld_constant_real3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_le_real4 (&val, + ffebld_constant_real4 (ffebld_conter (l)), + ffebld_constant_real4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad real kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeCHARACTER1: + error = ffetarget_le_character1 (&val, + ffebld_constant_character1 (ffebld_conter (l)), + ffebld_constant_character1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCHARACTER2 + case FFEINFO_kindtypeCHARACTER2: + error = ffetarget_le_character2 (&val, + ffebld_constant_character2 (ffebld_conter (l)), + ffebld_constant_character2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCHARACTER3 + case FFEINFO_kindtypeCHARACTER3: + error = ffetarget_le_character3 (&val, + ffebld_constant_character3 (ffebld_conter (l)), + ffebld_constant_character3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCHARACTER4 + case FFEINFO_kindtypeCHARACTER4: + error = ffetarget_le_character4 (&val, + ffebld_constant_character4 (ffebld_conter (l)), + ffebld_constant_character4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad character kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_lt -- Collapse lt expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_lt(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_lt (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebld r; + bool val; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + r = ffebld_right (expr); + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr)))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_lt_integer1 (&val, + ffebld_constant_integer1 (ffebld_conter (l)), + ffebld_constant_integer1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_lt_integer2 (&val, + ffebld_constant_integer2 (ffebld_conter (l)), + ffebld_constant_integer2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_lt_integer3 (&val, + ffebld_constant_integer3 (ffebld_conter (l)), + ffebld_constant_integer3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_lt_integer4 (&val, + ffebld_constant_integer4 (ffebld_conter (l)), + ffebld_constant_integer4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeREAL: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okREAL1 + case FFEINFO_kindtypeREAL1: + error = ffetarget_lt_real1 (&val, + ffebld_constant_real1 (ffebld_conter (l)), + ffebld_constant_real1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okREAL2 + case FFEINFO_kindtypeREAL2: + error = ffetarget_lt_real2 (&val, + ffebld_constant_real2 (ffebld_conter (l)), + ffebld_constant_real2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okREAL3 + case FFEINFO_kindtypeREAL3: + error = ffetarget_lt_real3 (&val, + ffebld_constant_real3 (ffebld_conter (l)), + ffebld_constant_real3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okREAL4 + case FFEINFO_kindtypeREAL4: + error = ffetarget_lt_real4 (&val, + ffebld_constant_real4 (ffebld_conter (l)), + ffebld_constant_real4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad real kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr)))) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeCHARACTER1: + error = ffetarget_lt_character1 (&val, + ffebld_constant_character1 (ffebld_conter (l)), + ffebld_constant_character1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCHARACTER2 + case FFEINFO_kindtypeCHARACTER2: + error = ffetarget_lt_character2 (&val, + ffebld_constant_character2 (ffebld_conter (l)), + ffebld_constant_character2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCHARACTER3 + case FFEINFO_kindtypeCHARACTER3: + error = ffetarget_lt_character3 (&val, + ffebld_constant_character3 (ffebld_conter (l)), + ffebld_constant_character3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + +#if FFETARGET_okCHARACTER4 + case FFEINFO_kindtypeCHARACTER4: + error = ffetarget_lt_character4 (&val, + ffebld_constant_character4 (ffebld_conter (l)), + ffebld_constant_character4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig + (ffebld_constant_new_logicaldefault (val), expr); + break; +#endif + + default: + assert ("bad character kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_and -- Collapse and expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_and(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_and (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebld r; + ffebldConstantUnion u; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + r = ffebld_right (expr); + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + switch (bt = ffeinfo_basictype (ffebld_info (expr))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u), + ffebld_constant_integer1 (ffebld_conter (l)), + ffebld_constant_integer1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val + (ffebld_cu_val_integer1 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u), + ffebld_constant_integer2 (ffebld_conter (l)), + ffebld_constant_integer2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val + (ffebld_cu_val_integer2 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u), + ffebld_constant_integer3 (ffebld_conter (l)), + ffebld_constant_integer3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val + (ffebld_cu_val_integer3 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u), + ffebld_constant_integer4 (ffebld_conter (l)), + ffebld_constant_integer4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val + (ffebld_cu_val_integer4 (u)), expr); + break; +#endif + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u), + ffebld_constant_logical1 (ffebld_conter (l)), + ffebld_constant_logical1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val + (ffebld_cu_val_logical1 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u), + ffebld_constant_logical2 (ffebld_conter (l)), + ffebld_constant_logical2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val + (ffebld_cu_val_logical2 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u), + ffebld_constant_logical3 (ffebld_conter (l)), + ffebld_constant_logical3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val + (ffebld_cu_val_logical3 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u), + ffebld_constant_logical4 (ffebld_conter (l)), + ffebld_constant_logical4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val + (ffebld_cu_val_logical4 (u)), expr); + break; +#endif + + default: + assert ("bad logical kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (bt, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_or -- Collapse or expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_or(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_or (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebld r; + ffebldConstantUnion u; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + r = ffebld_right (expr); + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + switch (bt = ffeinfo_basictype (ffebld_info (expr))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u), + ffebld_constant_integer1 (ffebld_conter (l)), + ffebld_constant_integer1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val + (ffebld_cu_val_integer1 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u), + ffebld_constant_integer2 (ffebld_conter (l)), + ffebld_constant_integer2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val + (ffebld_cu_val_integer2 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u), + ffebld_constant_integer3 (ffebld_conter (l)), + ffebld_constant_integer3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val + (ffebld_cu_val_integer3 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u), + ffebld_constant_integer4 (ffebld_conter (l)), + ffebld_constant_integer4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val + (ffebld_cu_val_integer4 (u)), expr); + break; +#endif + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u), + ffebld_constant_logical1 (ffebld_conter (l)), + ffebld_constant_logical1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val + (ffebld_cu_val_logical1 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u), + ffebld_constant_logical2 (ffebld_conter (l)), + ffebld_constant_logical2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val + (ffebld_cu_val_logical2 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u), + ffebld_constant_logical3 (ffebld_conter (l)), + ffebld_constant_logical3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val + (ffebld_cu_val_logical3 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u), + ffebld_constant_logical4 (ffebld_conter (l)), + ffebld_constant_logical4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val + (ffebld_cu_val_logical4 (u)), expr); + break; +#endif + + default: + assert ("bad logical kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (bt, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_xor -- Collapse xor expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_xor(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_xor (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebld r; + ffebldConstantUnion u; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + r = ffebld_right (expr); + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + switch (bt = ffeinfo_basictype (ffebld_info (expr))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u), + ffebld_constant_integer1 (ffebld_conter (l)), + ffebld_constant_integer1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val + (ffebld_cu_val_integer1 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u), + ffebld_constant_integer2 (ffebld_conter (l)), + ffebld_constant_integer2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val + (ffebld_cu_val_integer2 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u), + ffebld_constant_integer3 (ffebld_conter (l)), + ffebld_constant_integer3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val + (ffebld_cu_val_integer3 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u), + ffebld_constant_integer4 (ffebld_conter (l)), + ffebld_constant_integer4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val + (ffebld_cu_val_integer4 (u)), expr); + break; +#endif + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u), + ffebld_constant_logical1 (ffebld_conter (l)), + ffebld_constant_logical1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val + (ffebld_cu_val_logical1 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u), + ffebld_constant_logical2 (ffebld_conter (l)), + ffebld_constant_logical2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val + (ffebld_cu_val_logical2 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u), + ffebld_constant_logical3 (ffebld_conter (l)), + ffebld_constant_logical3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val + (ffebld_cu_val_logical3 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u), + ffebld_constant_logical4 (ffebld_conter (l)), + ffebld_constant_logical4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val + (ffebld_cu_val_logical4 (u)), expr); + break; +#endif + + default: + assert ("bad logical kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (bt, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_eqv -- Collapse eqv expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_eqv(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_eqv (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebld r; + ffebldConstantUnion u; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + r = ffebld_right (expr); + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + switch (bt = ffeinfo_basictype (ffebld_info (expr))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u), + ffebld_constant_integer1 (ffebld_conter (l)), + ffebld_constant_integer1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val + (ffebld_cu_val_integer1 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u), + ffebld_constant_integer2 (ffebld_conter (l)), + ffebld_constant_integer2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val + (ffebld_cu_val_integer2 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u), + ffebld_constant_integer3 (ffebld_conter (l)), + ffebld_constant_integer3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val + (ffebld_cu_val_integer3 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u), + ffebld_constant_integer4 (ffebld_conter (l)), + ffebld_constant_integer4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val + (ffebld_cu_val_integer4 (u)), expr); + break; +#endif + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u), + ffebld_constant_logical1 (ffebld_conter (l)), + ffebld_constant_logical1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val + (ffebld_cu_val_logical1 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u), + ffebld_constant_logical2 (ffebld_conter (l)), + ffebld_constant_logical2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val + (ffebld_cu_val_logical2 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u), + ffebld_constant_logical3 (ffebld_conter (l)), + ffebld_constant_logical3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val + (ffebld_cu_val_logical3 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u), + ffebld_constant_logical4 (ffebld_conter (l)), + ffebld_constant_logical4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val + (ffebld_cu_val_logical4 (u)), expr); + break; +#endif + + default: + assert ("bad logical kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (bt, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_neqv -- Collapse neqv expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_neqv(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_neqv (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebld r; + ffebldConstantUnion u; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + r = ffebld_right (expr); + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + if (ffebld_op (r) != FFEBLD_opCONTER) + return expr; + + switch (bt = ffeinfo_basictype (ffebld_info (expr))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeINTEGER: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okINTEGER1 + case FFEINFO_kindtypeINTEGER1: + error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u), + ffebld_constant_integer1 (ffebld_conter (l)), + ffebld_constant_integer1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val + (ffebld_cu_val_integer1 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER2 + case FFEINFO_kindtypeINTEGER2: + error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u), + ffebld_constant_integer2 (ffebld_conter (l)), + ffebld_constant_integer2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val + (ffebld_cu_val_integer2 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER3 + case FFEINFO_kindtypeINTEGER3: + error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u), + ffebld_constant_integer3 (ffebld_conter (l)), + ffebld_constant_integer3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val + (ffebld_cu_val_integer3 (u)), expr); + break; +#endif + +#if FFETARGET_okINTEGER4 + case FFEINFO_kindtypeINTEGER4: + error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u), + ffebld_constant_integer4 (ffebld_conter (l)), + ffebld_constant_integer4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val + (ffebld_cu_val_integer4 (u)), expr); + break; +#endif + + default: + assert ("bad integer kind type" == NULL); + break; + } + break; + + case FFEINFO_basictypeLOGICAL: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okLOGICAL1 + case FFEINFO_kindtypeLOGICAL1: + error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u), + ffebld_constant_logical1 (ffebld_conter (l)), + ffebld_constant_logical1 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val + (ffebld_cu_val_logical1 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL2 + case FFEINFO_kindtypeLOGICAL2: + error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u), + ffebld_constant_logical2 (ffebld_conter (l)), + ffebld_constant_logical2 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val + (ffebld_cu_val_logical2 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL3 + case FFEINFO_kindtypeLOGICAL3: + error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u), + ffebld_constant_logical3 (ffebld_conter (l)), + ffebld_constant_logical3 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val + (ffebld_cu_val_logical3 (u)), expr); + break; +#endif + +#if FFETARGET_okLOGICAL4 + case FFEINFO_kindtypeLOGICAL4: + error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u), + ffebld_constant_logical4 (ffebld_conter (l)), + ffebld_constant_logical4 (ffebld_conter (r))); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val + (ffebld_cu_val_logical4 (u)), expr); + break; +#endif + + default: + assert ("bad logical kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (bt, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_collapse_symter -- Collapse symter expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_symter(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED) +{ + ffebld r; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffetargetCharacterSize len; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL) + return expr; /* A PARAMETER lhs in progress. */ + + switch (ffebld_op (r)) + { + case FFEBLD_opCONTER: + break; + + case FFEBLD_opANY: + return r; + + default: + return expr; + } + + bt = ffeinfo_basictype (ffebld_info (r)); + kt = ffeinfo_kindtype (ffebld_info (r)); + len = ffebld_size (r); + + expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)), + expr); + + ffebld_set_info (expr, ffeinfo_new + (bt, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + len)); + + return expr; +} + +/* ffeexpr_collapse_funcref -- Collapse funcref expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_funcref(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED) +{ + return expr; /* ~~someday go ahead and collapse these, + though not required */ +} + +/* ffeexpr_collapse_arrayref -- Collapse arrayref expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_arrayref(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED) +{ + return expr; +} + +/* ffeexpr_collapse_substr -- Collapse substr expr + + ffebld expr; + ffelexToken token; + expr = ffeexpr_collapse_substr(expr,token); + + If the result of the expr is a constant, replaces the expr with the + computed constant. */ + +ffebld +ffeexpr_collapse_substr (ffebld expr, ffelexToken t) +{ + ffebad error = FFEBAD; + ffebld l; + ffebld r; + ffebld start; + ffebld stop; + ffebldConstantUnion u; + ffeinfoKindtype kt; + ffetargetCharacterSize len; + ffetargetIntegerDefault first; + ffetargetIntegerDefault last; + + if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT) + return expr; + + l = ffebld_left (expr); + r = ffebld_right (expr); /* opITEM. */ + + if (ffebld_op (l) != FFEBLD_opCONTER) + return expr; + + kt = ffeinfo_kindtype (ffebld_info (l)); + len = ffebld_size (l); + + start = ffebld_head (r); + stop = ffebld_head (ffebld_trail (r)); + if (start == NULL) + first = 1; + else + { + if ((ffebld_op (start) != FFEBLD_opCONTER) + || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER) + || (ffeinfo_kindtype (ffebld_info (start)) + != FFEINFO_kindtypeINTEGERDEFAULT)) + return expr; + first = ffebld_constant_integerdefault (ffebld_conter (start)); + } + if (stop == NULL) + last = len; + else + { + if ((ffebld_op (stop) != FFEBLD_opCONTER) + || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER) + || (ffeinfo_kindtype (ffebld_info (stop)) + != FFEINFO_kindtypeINTEGERDEFAULT)) + return expr; + last = ffebld_constant_integerdefault (ffebld_conter (stop)); + } + + /* Handle problems that should have already been diagnosed, but + left in the expression tree. */ + + if (first <= 0) + first = 1; + if (last < first) + last = first + len - 1; + + if ((first == 1) && (last == len)) + { /* Same as original. */ + expr = ffebld_new_conter_with_orig (ffebld_constant_copy + (ffebld_conter (l)), expr); + ffebld_set_info (expr, ffeinfo_new + (FFEINFO_basictypeCHARACTER, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + len)); + + return expr; + } + + switch (ffeinfo_basictype (ffebld_info (expr))) + { + case FFEINFO_basictypeANY: + return expr; + + case FFEINFO_basictypeCHARACTER: + switch (kt = ffeinfo_kindtype (ffebld_info (expr))) + { +#if FFETARGET_okCHARACTER1 + case FFEINFO_kindtypeCHARACTER1: + error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u), + ffebld_constant_character1 (ffebld_conter (l)), first, last, + ffebld_constant_pool (), &len); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val + (ffebld_cu_val_character1 (u)), expr); + break; +#endif + +#if FFETARGET_okCHARACTER2 + case FFEINFO_kindtypeCHARACTER2: + error = ffetarget_substr_character2 (ffebld_cu_ptr_character2 (u), + ffebld_constant_character2 (ffebld_conter (l)), first, last, + ffebld_constant_pool (), &len); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val + (ffebld_cu_val_character2 (u)), expr); + break; +#endif + +#if FFETARGET_okCHARACTER3 + case FFEINFO_kindtypeCHARACTER3: + error = ffetarget_substr_character3 (ffebld_cu_ptr_character3 (u), + ffebld_constant_character3 (ffebld_conter (l)), first, last, + ffebld_constant_pool (), &len); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val + (ffebld_cu_val_character3 (u)), expr); + break; +#endif + +#if FFETARGET_okCHARACTER4 + case FFEINFO_kindtypeCHARACTER4: + error = ffetarget_substr_character4 (ffebld_cu_ptr_character4 (u), + ffebld_constant_character4 (ffebld_conter (l)), first, last, + ffebld_constant_pool (), &len); + expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val + (ffebld_cu_val_character4 (u)), expr); + break; +#endif + + default: + assert ("bad character kind type" == NULL); + break; + } + break; + + default: + assert ("bad type" == NULL); + return expr; + } + + ffebld_set_info (expr, ffeinfo_new + (FFEINFO_basictypeCHARACTER, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + len)); + + if ((error != FFEBAD) + && ffebad_start (error)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + return expr; +} + +/* ffeexpr_convert -- Convert source expression to given type + + ffebld source; + ffelexToken source_token; + ffelexToken dest_token; // Any appropriate token for "destination". + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffetargetCharactersize sz; + ffeexprContext context; // Mainly LET or DATA. + source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context); + + If the expression conforms, returns the source expression. Otherwise + returns source wrapped in a convert node doing the conversion, or + ANY wrapped in convert if there is a conversion error (and issues an + error message). Be sensitive to the context for certain aspects of + the conversion. */ + +ffebld +ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token, + ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk, + ffetargetCharacterSize sz, ffeexprContext context) +{ + bool bad; + ffeinfo info; + ffeinfoWhere wh; + + info = ffebld_info (source); + if ((bt != ffeinfo_basictype (info)) + || (kt != ffeinfo_kindtype (info)) + || (rk != 0) /* Can't convert from or to arrays yet. */ + || (ffeinfo_rank (info) != 0) + || (sz != ffebld_size_known (source))) +#if 0 /* Nobody seems to need this spurious CONVERT node. */ + || ((context != FFEEXPR_contextLET) + && (bt == FFEINFO_basictypeCHARACTER) + && (sz == FFETARGET_charactersizeNONE))) +#endif + { + switch (ffeinfo_basictype (info)) + { + case FFEINFO_basictypeLOGICAL: + switch (bt) + { + case FFEINFO_basictypeLOGICAL: + bad = FALSE; + break; + + case FFEINFO_basictypeINTEGER: + bad = !ffe_is_ugly_logint (); + break; + + case FFEINFO_basictypeCHARACTER: + bad = ffe_is_pedantic () + || !(ffe_is_ugly_init () + && (context == FFEEXPR_contextDATA)); + break; + + default: + bad = TRUE; + break; + } + break; + + case FFEINFO_basictypeINTEGER: + switch (bt) + { + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeREAL: + case FFEINFO_basictypeCOMPLEX: + bad = FALSE; + break; + + case FFEINFO_basictypeLOGICAL: + bad = !ffe_is_ugly_logint (); + break; + + case FFEINFO_basictypeCHARACTER: + bad = ffe_is_pedantic () + || !(ffe_is_ugly_init () + && (context == FFEEXPR_contextDATA)); + break; + + default: + bad = TRUE; + break; + } + break; + + case FFEINFO_basictypeREAL: + case FFEINFO_basictypeCOMPLEX: + switch (bt) + { + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeREAL: + case FFEINFO_basictypeCOMPLEX: + bad = FALSE; + break; + + case FFEINFO_basictypeCHARACTER: + bad = TRUE; + break; + + default: + bad = TRUE; + break; + } + break; + + case FFEINFO_basictypeCHARACTER: + bad = (bt != FFEINFO_basictypeCHARACTER) + && (ffe_is_pedantic () + || (bt != FFEINFO_basictypeINTEGER) + || !(ffe_is_ugly_init () + && (context == FFEEXPR_contextDATA))); + break; + + case FFEINFO_basictypeTYPELESS: + case FFEINFO_basictypeHOLLERITH: + bad = ffe_is_pedantic () + || !(ffe_is_ugly_init () + && ((context == FFEEXPR_contextDATA) + || (context == FFEEXPR_contextLET))); + break; + + default: + bad = TRUE; + break; + } + + if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0))) + bad = TRUE; + + if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY) + && (ffeinfo_basictype (info) != FFEINFO_basictypeANY) + && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY) + && (ffeinfo_where (info) != FFEINFO_whereANY)) + { + if (ffebad_start (FFEBAD_BAD_TYPES)) + { + if (dest_token == NULL) + ffebad_here (0, ffewhere_line_unknown (), + ffewhere_column_unknown ()); + else + ffebad_here (0, ffelex_token_where_line (dest_token), + ffelex_token_where_column (dest_token)); + assert (source_token != NULL); + ffebad_here (1, ffelex_token_where_line (source_token), + ffelex_token_where_column (source_token)); + ffebad_finish (); + } + + source = ffebld_new_any (); + ffebld_set_info (source, ffeinfo_new_any ()); + } + else + { + switch (ffeinfo_where (info)) + { + case FFEINFO_whereCONSTANT: + wh = FFEINFO_whereCONSTANT; + break; + + case FFEINFO_whereIMMEDIATE: + wh = FFEINFO_whereIMMEDIATE; + break; + + default: + wh = FFEINFO_whereFLEETING; + break; + } + source = ffebld_new_convert (source); + ffebld_set_info (source, ffeinfo_new + (bt, + kt, + 0, + FFEINFO_kindENTITY, + wh, + sz)); + source = ffeexpr_collapse_convert (source, source_token); + } + } + + return source; +} + +/* ffeexpr_convert_expr -- Convert source expr to conform to dest expr + + ffebld source; + ffebld dest; + ffelexToken source_token; + ffelexToken dest_token; + ffeexprContext context; + source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context); + + If the expressions conform, returns the source expression. Otherwise + returns source wrapped in a convert node doing the conversion, or + ANY wrapped in convert if there is a conversion error (and issues an + error message). Be sensitive to the context, such as LET or DATA. */ + +ffebld +ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest, + ffelexToken dest_token, ffeexprContext context) +{ + ffeinfo info; + + info = ffebld_info (dest); + return ffeexpr_convert (source, source_token, dest_token, + ffeinfo_basictype (info), + ffeinfo_kindtype (info), + ffeinfo_rank (info), + ffebld_size_known (dest), + context); +} + +/* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol + + ffebld source; + ffesymbol dest; + ffelexToken source_token; + ffelexToken dest_token; + source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token); + + If the expressions conform, returns the source expression. Otherwise + returns source wrapped in a convert node doing the conversion, or + ANY wrapped in convert if there is a conversion error (and issues an + error message). */ + +ffebld +ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token, + ffesymbol dest, ffelexToken dest_token) +{ + return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest), + ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest), + FFEEXPR_contextLET); +} + +/* Initializes the module. */ + +void +ffeexpr_init_2 () +{ + ffeexpr_stack_ = NULL; + ffeexpr_level_ = 0; +} + +/* ffeexpr_lhs -- Begin processing left-hand-side-context expression + + Prepares cluster for delivery of lexer tokens representing an expression + in a left-hand-side context (A in A=B, for example). ffebld is used + to build expressions in the given pool. The appropriate lexer-token + handling routine within ffeexpr is returned. When the end of the + expression is detected, mycallbackroutine is called with the resulting + single ffebld object specifying the entire expression and the first + lexer token that is not considered part of the expression. This caller- + supplied routine itself returns a lexer-token handling routine. Thus, + if necessary, ffeexpr can return several tokens as end-of-expression + tokens if it needs to scan forward more than one in any instance. */ + +ffelexHandler +ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback) +{ + ffeexprStack_ s; + + ffebld_pool_push (pool); + s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s)); + s->previous = ffeexpr_stack_; + s->pool = pool; + s->context = context; + s->callback = callback; + s->first_token = NULL; + s->exprstack = NULL; + s->is_rhs = FALSE; + ffeexpr_stack_ = s; + return (ffelexHandler) ffeexpr_token_first_lhs_; +} + +/* ffeexpr_rhs -- Begin processing right-hand-side-context expression + + return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine); // to lexer. + + Prepares cluster for delivery of lexer tokens representing an expression + in a right-hand-side context (B in A=B, for example). ffebld is used + to build expressions in the given pool. The appropriate lexer-token + handling routine within ffeexpr is returned. When the end of the + expression is detected, mycallbackroutine is called with the resulting + single ffebld object specifying the entire expression and the first + lexer token that is not considered part of the expression. This caller- + supplied routine itself returns a lexer-token handling routine. Thus, + if necessary, ffeexpr can return several tokens as end-of-expression + tokens if it needs to scan forward more than one in any instance. */ + +ffelexHandler +ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback) +{ + ffeexprStack_ s; + + ffebld_pool_push (pool); + s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s)); + s->previous = ffeexpr_stack_; + s->pool = pool; + s->context = context; + s->callback = callback; + s->first_token = NULL; + s->exprstack = NULL; + s->is_rhs = TRUE; + ffeexpr_stack_ = s; + return (ffelexHandler) ffeexpr_token_first_rhs_; +} + +/* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr + + Pass it to ffeexpr_rhs as the callback routine. + + Makes sure the end token is close-paren and swallows it, else issues + an error message and doesn't swallow the token (passing it along instead). + In either case wraps up subexpression construction by enclosing the + ffebld expression in a paren. */ + +static ffelexHandler +ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + ffeexprExpr_ e; + + if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) + { + /* Oops, naughty user didn't specify the close paren! */ + + if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), + ffelex_token_where_column (ffeexpr_stack_->tokens[0])); + ffebad_finish (); + } + + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + e->u.operand = ffebld_new_any (); + ffebld_set_info (e->u.operand, ffeinfo_new_any ()); + ffeexpr_exprstack_push_operand_ (e); + + return + (ffelexHandler) ffeexpr_find_close_paren_ (t, + (ffelexHandler) + ffeexpr_token_binary_); + } + + if (expr->op == FFEBLD_opIMPDO) + { + if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), + ffelex_token_where_column (ffeexpr_stack_->tokens[0])); + ffebad_finish (); + } + } + else + { + expr = ffebld_new_paren (expr); + ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr)))); + } + + /* Now push the (parenthesized) expression as an operand onto the + expression stack. */ + + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + e->u.operand = expr; + e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft); + e->token = ffeexpr_stack_->tokens[0]; + ffeexpr_exprstack_push_operand_ (e); + + return (ffelexHandler) ffeexpr_token_binary_; +} + +/* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr + + Pass it to ffeexpr_rhs as the callback routine. + + We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)" + with the next token in t. If the next token is possibly a binary + operator, continue processing the outer expression. If the next + token is COMMA, then the expression is a unit specifier, and + parentheses should not be added to it because it surrounds the + I/O control list that starts with the unit specifier (and continues + on from here -- we haven't seen the CLOSE_PAREN that matches the + OPEN_PAREN, it is up to the callback function to expect to see it + at some point). In this case, we notify the callback function that + the COMMA is inside, not outside, the parens by wrapping the expression + in an opITEM (with a NULL trail) -- the callback function presumably + unwraps it after seeing this kludgey indicator. + + If the next token is CLOSE_PAREN, then we go to the _1_ state to + decide what to do with the token after that. + + 15-Feb-91 JCB 1.1 + Use an extra state for the CLOSE_PAREN case to make READ &co really + work right. */ + +static ffelexHandler +ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + ffeexprCallback callback; + ffeexprStack_ s; + + if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) + { /* Need to see the next token before we + decide anything. */ + ffeexpr_stack_->expr = expr; + ffeexpr_tokens_[0] = ffelex_token_use (ft); + ffeexpr_tokens_[1] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_; + } + + expr = ffeexpr_finished_ambig_ (ft, expr); + + /* Let the callback function handle the case where t isn't COMMA. */ + + /* Here is a kludge whereby we tell the callback function the OPEN_PAREN + that preceded the expression starts a list of expressions, and the expr + hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN + node. The callback function should extract the real expr from the head + of this opITEM node after testing it. */ + + expr = ffebld_new_item (expr, NULL); + + ffebld_pool_pop (); + callback = ffeexpr_stack_->callback; + ffelex_token_kill (ffeexpr_stack_->first_token); + s = ffeexpr_stack_->previous; + malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); + ffeexpr_stack_ = s; + return (ffelexHandler) (*callback) (ft, expr, t); +} + +/* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN + + See ffeexpr_cb_close_paren_ambig_. + + We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)" + with the next token in t. If the next token is possibly a binary + operator, continue processing the outer expression. If the next + token is COMMA, the expression is a parenthesized format specifier. + If the next token is not EOS or SEMICOLON, then because it is not a + binary operator (it is NAME, OPEN_PAREN, &c), the expression is + a unit specifier, and parentheses should not be added to it because + they surround the I/O control list that consists of only the unit + specifier. If the next token is EOS or SEMICOLON, the statement + must be disambiguated by looking at the type of the expression -- a + character expression is a parenthesized format specifier, while a + non-character expression is a unit specifier. + + Another issue is how to do the callback so the recipient of the + next token knows how to handle it if it is a COMMA. In all other + cases, disambiguation is straightforward: the same approach as the + above is used. + + EXTENSION: in COMMA case, if not pedantic, use same disambiguation + as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]" + and apparently other compilers do, as well, and some code out there + uses this "feature". + + 19-Feb-91 JCB 1.1 + Extend to allow COMMA as nondisambiguating by itself. Remember + to not try and check info field for opSTAR, since that expr doesn't + have a valid info field. */ + +static ffelexHandler +ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t) +{ + ffeexprCallback callback; + ffeexprStack_ s; + ffelexHandler next; + ffelexToken orig_ft = ffeexpr_tokens_[0]; /* In case callback clobbers + these. */ + ffelexToken orig_t = ffeexpr_tokens_[1]; + ffebld expr = ffeexpr_stack_->expr; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: /* Subexpr is parenthesized format specifier. */ + if (ffe_is_pedantic ()) + goto pedantic_comma; /* :::::::::::::::::::: */ + /* Fall through. */ + case FFELEX_typeEOS: /* Ambiguous; use type of expr to + disambiguate. */ + case FFELEX_typeSEMICOLON: + if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY) + || (ffebld_op (expr) == FFEBLD_opSTAR) + || (ffeinfo_basictype (ffebld_info (expr)) + != FFEINFO_basictypeCHARACTER)) + break; /* Not a valid CHARACTER entity, can't be a + format spec. */ + /* Fall through. */ + default: /* Binary op (we assume; error otherwise); + format specifier. */ + + pedantic_comma: /* :::::::::::::::::::: */ + + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextFILENUMAMBIG: + ffeexpr_stack_->context = FFEEXPR_contextFILENUM; + break; + + case FFEEXPR_contextFILEUNITAMBIG: + ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; + break; + + default: + assert ("bad context" == NULL); + break; + } + + ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token); + next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t); + ffelex_token_kill (orig_ft); + ffelex_token_kill (orig_t); + return (ffelexHandler) (*next) (t); + + case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */ + case FFELEX_typeNAME: + break; + } + + expr = ffeexpr_finished_ambig_ (orig_ft, expr); + + /* Here is a kludge whereby we tell the callback function the OPEN_PAREN + that preceded the expression starts a list of expressions, and the expr + hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN + node. The callback function should extract the real expr from the head + of this opITEM node after testing it. */ + + expr = ffebld_new_item (expr, NULL); + + ffebld_pool_pop (); + callback = ffeexpr_stack_->callback; + ffelex_token_kill (ffeexpr_stack_->first_token); + s = ffeexpr_stack_->previous; + malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); + ffeexpr_stack_ = s; + next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t); + ffelex_token_kill (orig_ft); + ffelex_token_kill (orig_t); + return (ffelexHandler) (*next) (t); +} + +/* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex) + + Pass it to ffeexpr_rhs as the callback routine. + + Makes sure the end token is close-paren and swallows it, or a comma + and handles complex/implied-do possibilities, else issues + an error message and doesn't swallow the token (passing it along instead). */ + +static ffelexHandler +ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + /* First check to see if this is a possible complex entity. It is if the + token is a comma. */ + + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + { + ffeexpr_stack_->tokens[1] = ffelex_token_use (ft); + ffeexpr_stack_->expr = expr; + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_); + } + + return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t); +} + +/* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr + + Pass it to ffeexpr_rhs as the callback routine. + + If this token is not a comma, we have a complex constant (or an attempt + at one), so handle it accordingly, displaying error messages if the token + is not a close-paren. */ + +static ffelexHandler +ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + ffeexprExpr_ e; + ffeinfoBasictype lty = ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr)); + ffeinfoBasictype rty = ffeinfo_basictype (ffebld_info (expr)); + ffeinfoKindtype lkt; + ffeinfoKindtype rkt; + ffeinfoKindtype nkt; + bool ok = TRUE; + ffebld orig; + + if ((expr == NULL) + || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER) + || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL) + && (((ffebld_op (orig) != FFEBLD_opUMINUS) + && (ffebld_op (orig) != FFEBLD_opUPLUS)) + || (ffebld_conter_orig (ffebld_left (orig)) != NULL))) + || ((lty != FFEINFO_basictypeINTEGER) + && (lty != FFEINFO_basictypeREAL))) + { + if ((lty != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_INVALID_COMPLEX_PART)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]), + ffelex_token_where_column (ffeexpr_stack_->tokens[1])); + ffebad_string ("Real"); + ffebad_finish (); + } + ok = FALSE; + } + if ((expr == NULL) + || (ffebld_op (expr) != FFEBLD_opCONTER) + || (((orig = ffebld_conter_orig (expr)) != NULL) + && (((ffebld_op (orig) != FFEBLD_opUMINUS) + && (ffebld_op (orig) != FFEBLD_opUPLUS)) + || (ffebld_conter_orig (ffebld_left (orig)) != NULL))) + || ((rty != FFEINFO_basictypeINTEGER) + && (rty != FFEINFO_basictypeREAL))) + { + if ((rty != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_INVALID_COMPLEX_PART)) + { + ffebad_here (0, ffelex_token_where_line (ft), + ffelex_token_where_column (ft)); + ffebad_string ("Imaginary"); + ffebad_finish (); + } + ok = FALSE; + } + + ffelex_token_kill (ffeexpr_stack_->tokens[1]); + + /* Push the (parenthesized) expression as an operand onto the expression + stack. */ + + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + e->token = ffeexpr_stack_->tokens[0]; + + if (ok) + { + if (lty == FFEINFO_basictypeINTEGER) + lkt = FFEINFO_kindtypeREALDEFAULT; + else + lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr)); + if (rty == FFEINFO_basictypeINTEGER) + rkt = FFEINFO_kindtypeREALDEFAULT; + else + rkt = ffeinfo_kindtype (ffebld_info (expr)); + + nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt); + ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr, + ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0], + FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + expr = ffeexpr_convert (expr, + ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0], + FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + } + else + nkt = FFEINFO_kindtypeANY; + + switch (nkt) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: + e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1 + (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr))); + ffebld_set_info (e->u.operand, + ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0, + FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + break; +#endif + +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: + e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2 + (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr))); + ffebld_set_info (e->u.operand, + ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0, + FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + break; +#endif + +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: + e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3 + (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr))); + ffebld_set_info (e->u.operand, + ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0, + FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + break; +#endif + +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: + e->u.operand = ffebld_new_conter (ffebld_constant_new_complex4 + (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr))); + ffebld_set_info (e->u.operand, + ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0, + FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + break; +#endif + + default: + if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE) + ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), + ffelex_token_where_column (ffeexpr_stack_->tokens[0])); + ffebad_finish (); + } + /* Fall through. */ + case FFEINFO_kindtypeANY: + e->u.operand = ffebld_new_any (); + ffebld_set_info (e->u.operand, ffeinfo_new_any ()); + break; + } + ffeexpr_exprstack_push_operand_ (e); + + /* Now, if the token is a close parenthese, we're in great shape so return + the next handler. */ + + if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) + return (ffelexHandler) ffeexpr_token_binary_; + + /* Oops, naughty user didn't specify the close paren! */ + + if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN)) + { + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), + ffelex_token_where_column (ffeexpr_stack_->tokens[0])); + ffebad_finish (); + } + + return + (ffelexHandler) ffeexpr_find_close_paren_ (t, + (ffelexHandler) + ffeexpr_token_binary_); +} + +/* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or + implied-DO construct) + + Pass it to ffeexpr_rhs as the callback routine. + + Makes sure the end token is close-paren and swallows it, or a comma + and handles complex/implied-do possibilities, else issues + an error message and doesn't swallow the token (passing it along instead). */ + +static ffelexHandler +ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + ffeexprContext ctx; + + /* First check to see if this is a possible complex or implied-DO entity. + It is if the token is a comma. */ + + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + { + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextIOLIST: + case FFEEXPR_contextIMPDOITEM_: + ctx = FFEEXPR_contextIMPDOITEM_; + break; + + case FFEEXPR_contextIOLISTDF: + case FFEEXPR_contextIMPDOITEMDF_: + ctx = FFEEXPR_contextIMPDOITEMDF_; + break; + + default: + assert ("bad context" == NULL); + ctx = FFEEXPR_contextIMPDOITEM_; + break; + } + + ffeexpr_stack_->tokens[0] = ffelex_token_use (ft); + ffeexpr_stack_->expr = expr; + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + ctx, ffeexpr_cb_comma_ci_); + } + + ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token); + return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t); +} + +/* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr + + Pass it to ffeexpr_rhs as the callback routine. + + If this token is not a comma, we have a complex constant (or an attempt + at one), so handle it accordingly, displaying error messages if the token + is not a close-paren. If we have a comma here, it is an attempt at an + implied-DO, so start making a list accordingly. Oh, it might be an + equal sign also, meaning an implied-DO with only one item in its list. */ + +static ffelexHandler +ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + ffebld fexpr; + + /* First check to see if this is a possible complex constant. It is if the + token is not a comma or an equals sign, in which case it should be a + close-paren. */ + + if ((ffelex_token_type (t) != FFELEX_typeCOMMA) + && (ffelex_token_type (t) != FFELEX_typeEQUALS)) + { + ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0]; + ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token); + return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t); + } + + /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO + construct. Make a list and handle accordingly. */ + + ffelex_token_kill (ffeexpr_stack_->tokens[0]); + fexpr = ffeexpr_stack_->expr; + ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); + ffebld_append_item (&ffeexpr_stack_->bottom, fexpr); + return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t); +} + +/* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr + + Pass it to ffeexpr_rhs as the callback routine. + + Handle first item in an implied-DO construct. */ + +static ffelexHandler +ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + if (ffelex_token_type (t) != FFELEX_typeCOMMA) + { + if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), + ffelex_token_where_column (ffeexpr_stack_->first_token)); + ffebad_finish (); + } + ffebld_end_list (&ffeexpr_stack_->bottom); + ffeexpr_stack_->expr = ffebld_new_any (); + ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); + if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) + return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); + return (ffelexHandler) ffeexpr_cb_comma_i_5_; + } + + return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t); +} + +/* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr + + Pass it to ffeexpr_rhs as the callback routine. + + Handle first item in an implied-DO construct. */ + +static ffelexHandler +ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + ffeexprContext ctxi; + ffeexprContext ctxc; + + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextDATA: + case FFEEXPR_contextDATAIMPDOITEM_: + ctxi = FFEEXPR_contextDATAIMPDOITEM_; + ctxc = FFEEXPR_contextDATAIMPDOCTRL_; + break; + + case FFEEXPR_contextIOLIST: + case FFEEXPR_contextIMPDOITEM_: + ctxi = FFEEXPR_contextIMPDOITEM_; + ctxc = FFEEXPR_contextIMPDOCTRL_; + break; + + case FFEEXPR_contextIOLISTDF: + case FFEEXPR_contextIMPDOITEMDF_: + ctxi = FFEEXPR_contextIMPDOITEMDF_; + ctxc = FFEEXPR_contextIMPDOCTRL_; + break; + + default: + assert ("bad context" == NULL); + ctxi = FFEEXPR_context; + ctxc = FFEEXPR_context; + break; + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffebld_append_item (&ffeexpr_stack_->bottom, expr); + if (ffeexpr_stack_->is_rhs) + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + ctxi, ffeexpr_cb_comma_i_1_); + return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool, + ctxi, ffeexpr_cb_comma_i_1_); + + case FFELEX_typeEQUALS: + ffebld_end_list (&ffeexpr_stack_->bottom); + + /* Complain if implied-DO variable in list of items to be read. */ + + if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs) + ffeexpr_check_impdo_ (ffeexpr_stack_->expr, + ffeexpr_stack_->first_token, expr, ft); + + /* Set doiter flag for all appropriate SYMTERs. */ + + ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr); + + ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL); + ffebld_set_info (ffeexpr_stack_->expr, + ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, + 0, + FFEINFO_kindNONE, + FFEINFO_whereNONE, + FFETARGET_charactersizeNONE)); + ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)), + &ffeexpr_stack_->bottom); + ffebld_append_item (&ffeexpr_stack_->bottom, expr); + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + ctxc, ffeexpr_cb_comma_i_2_); + + default: + if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), + ffelex_token_where_column (ffeexpr_stack_->first_token)); + ffebad_finish (); + } + ffebld_end_list (&ffeexpr_stack_->bottom); + ffeexpr_stack_->expr = ffebld_new_any (); + ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); + if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) + return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); + return (ffelexHandler) ffeexpr_cb_comma_i_5_; + } +} + +/* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr + + Pass it to ffeexpr_rhs as the callback routine. + + Handle start-value in an implied-DO construct. */ + +static ffelexHandler +ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) +{ + ffeexprContext ctx; + + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextDATA: + case FFEEXPR_contextDATAIMPDOITEM_: + ctx = FFEEXPR_contextDATAIMPDOCTRL_; + break; + + case FFEEXPR_contextIOLIST: + case FFEEXPR_contextIOLISTDF: + case FFEEXPR_contextIMPDOITEM_: + case FFEEXPR_contextIMPDOITEMDF_: + ctx = FFEEXPR_contextIMPDOCTRL_; + break; + + default: + assert ("bad context" == NULL); + ctx = FFEEXPR_context; + break; + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffebld_append_item (&ffeexpr_stack_->bottom, expr); + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + ctx, ffeexpr_cb_comma_i_3_); + break; + + default: + if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), + ffelex_token_where_column (ffeexpr_stack_->first_token)); + ffebad_finish (); + } + ffebld_end_list (&ffeexpr_stack_->bottom); + ffeexpr_stack_->expr = ffebld_new_any (); + ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); + if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) + return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); + return (ffelexHandler) ffeexpr_cb_comma_i_5_; + } +} + +/* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr + + Pass it to ffeexpr_rhs as the callback routine. + + Handle end-value in an implied-DO construct. */ + +static ffelexHandler +ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) +{ + ffeexprContext ctx; + + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextDATA: + case FFEEXPR_contextDATAIMPDOITEM_: + ctx = FFEEXPR_contextDATAIMPDOCTRL_; + break; + + case FFEEXPR_contextIOLIST: + case FFEEXPR_contextIOLISTDF: + case FFEEXPR_contextIMPDOITEM_: + case FFEEXPR_contextIMPDOITEMDF_: + ctx = FFEEXPR_contextIMPDOCTRL_; + break; + + default: + assert ("bad context" == NULL); + ctx = FFEEXPR_context; + break; + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffebld_append_item (&ffeexpr_stack_->bottom, expr); + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + ctx, ffeexpr_cb_comma_i_4_); + break; + + case FFELEX_typeCLOSE_PAREN: + ffebld_append_item (&ffeexpr_stack_->bottom, expr); + return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t); + break; + + default: + if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), + ffelex_token_where_column (ffeexpr_stack_->first_token)); + ffebad_finish (); + } + ffebld_end_list (&ffeexpr_stack_->bottom); + ffeexpr_stack_->expr = ffebld_new_any (); + ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); + if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) + return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); + return (ffelexHandler) ffeexpr_cb_comma_i_5_; + } +} + +/* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr + [COMMA expr] + + Pass it to ffeexpr_rhs as the callback routine. + + Handle incr-value in an implied-DO construct. */ + +static ffelexHandler +ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + ffebld_append_item (&ffeexpr_stack_->bottom, expr); + ffebld_end_list (&ffeexpr_stack_->bottom); + { + ffebld item; + + for (item = ffebld_left (ffeexpr_stack_->expr); + item != NULL; + item = ffebld_trail (item)) + if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY) + goto replace_with_any; /* :::::::::::::::::::: */ + + for (item = ffebld_right (ffeexpr_stack_->expr); + item != NULL; + item = ffebld_trail (item)) + if ((ffebld_head (item) != NULL) /* Increment may be NULL. */ + && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)) + goto replace_with_any; /* :::::::::::::::::::: */ + } + break; + + default: + if (ffest_ffebad_start (FFEBAD_BAD_IMPDO)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), + ffelex_token_where_column (ffeexpr_stack_->first_token)); + ffebad_finish (); + } + ffebld_end_list (&ffeexpr_stack_->bottom); + + replace_with_any: /* :::::::::::::::::::: */ + + ffeexpr_stack_->expr = ffebld_new_any (); + ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ()); + break; + } + + if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) + return (ffelexHandler) ffeexpr_cb_comma_i_5_; + return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t); +} + +/* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr + [COMMA expr] CLOSE_PAREN + + Pass it to ffeexpr_rhs as the callback routine. + + Collects token following implied-DO construct for callback function. */ + +static ffelexHandler +ffeexpr_cb_comma_i_5_ (ffelexToken t) +{ + ffeexprCallback callback; + ffeexprStack_ s; + ffelexHandler next; + ffelexToken ft; + ffebld expr; + bool terminate; + + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextDATA: + case FFEEXPR_contextDATAIMPDOITEM_: + terminate = TRUE; + break; + + case FFEEXPR_contextIOLIST: + case FFEEXPR_contextIOLISTDF: + case FFEEXPR_contextIMPDOITEM_: + case FFEEXPR_contextIMPDOITEMDF_: + terminate = FALSE; + break; + + default: + assert ("bad context" == NULL); + terminate = FALSE; + break; + } + + ffebld_pool_pop (); + callback = ffeexpr_stack_->callback; + ft = ffeexpr_stack_->first_token; + expr = ffeexpr_stack_->expr; + s = ffeexpr_stack_->previous; + malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, + sizeof (*ffeexpr_stack_)); + ffeexpr_stack_ = s; + next = (ffelexHandler) (*callback) (ft, expr, t); + ffelex_token_kill (ft); + if (terminate) + { + ffesymbol_drive_sfnames (ffeexpr_check_impctrl_); + --ffeexpr_level_; + if (ffeexpr_level_ == 0) + ffe_terminate_4 (); + } + return (ffelexHandler) next; +} + +/* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression + + Makes sure the end token is close-paren and swallows it, else issues + an error message and doesn't swallow the token (passing it along instead). + In either case wraps up subexpression construction by enclosing the + ffebld expression in a %LOC. */ + +static ffelexHandler +ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) +{ + ffeexprExpr_ e; + + /* First push the (%LOC) expression as an operand onto the expression + stack. */ + + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + e->token = ffeexpr_stack_->tokens[0]; + e->u.operand = ffebld_new_percent_loc (expr); + ffebld_set_info (e->u.operand, + ffeinfo_new (FFEINFO_basictypeINTEGER, + ffecom_pointer_kind (), + 0, + FFEINFO_kindENTITY, + FFEINFO_whereFLEETING, + FFETARGET_charactersizeNONE)); +#if 0 /* ~~ */ + e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft); +#endif + ffeexpr_exprstack_push_operand_ (e); + + /* Now, if the token is a close parenthese, we're in great shape so return + the next handler. */ + + if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) + { + ffelex_token_kill (ffeexpr_stack_->tokens[1]); + return (ffelexHandler) ffeexpr_token_binary_; + } + + /* Oops, naughty user didn't specify the close paren! */ + + if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]), + ffelex_token_where_column (ffeexpr_stack_->tokens[1])); + ffebad_finish (); + } + + ffelex_token_kill (ffeexpr_stack_->tokens[1]); + return + (ffelexHandler) ffeexpr_find_close_paren_ (t, + (ffelexHandler) + ffeexpr_token_binary_); +} + +/* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr + + Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR). */ + +static ffelexHandler +ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + ffeexprExpr_ e; + ffebldOp op; + + /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all + such things until the lowest-level expression is reached. */ + + op = ffebld_op (expr); + if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF) + || (op == FFEBLD_opPERCENT_DESCR)) + { + if (ffebad_start (FFEBAD_NESTED_PERCENT)) + { + ffebad_here (0, ffelex_token_where_line (ft), + ffelex_token_where_column (ft)); + ffebad_finish (); + } + + do + { + expr = ffebld_left (expr); + op = ffebld_op (expr); + } + while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF) + || (op == FFEBLD_opPERCENT_DESCR)); + } + + /* Push the expression as an operand onto the expression stack. */ + + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + e->token = ffeexpr_stack_->tokens[0]; + switch (ffeexpr_stack_->percent) + { + case FFEEXPR_percentVAL_: + e->u.operand = ffebld_new_percent_val (expr); + break; + + case FFEEXPR_percentREF_: + e->u.operand = ffebld_new_percent_ref (expr); + break; + + case FFEEXPR_percentDESCR_: + e->u.operand = ffebld_new_percent_descr (expr); + break; + + default: + assert ("%lossage" == NULL); + e->u.operand = expr; + break; + } + ffebld_set_info (e->u.operand, ffebld_info (expr)); +#if 0 /* ~~ */ + e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft); +#endif + ffeexpr_exprstack_push_operand_ (e); + + /* Now, if the token is a close parenthese, we're in great shape so return + the next handler. */ + + if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) + return (ffelexHandler) ffeexpr_cb_end_notloc_1_; + + /* Oops, naughty user didn't specify the close paren! */ + + if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]), + ffelex_token_where_column (ffeexpr_stack_->tokens[1])); + ffebad_finish (); + } + + ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC); + + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; + break; + + case FFEEXPR_contextINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; + break; + + case FFEEXPR_contextSFUNCDEFACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; + break; + + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; + break; + + default: + assert ("bad context?!?!" == NULL); + break; + } + + ffelex_token_kill (ffeexpr_stack_->tokens[1]); + return + (ffelexHandler) ffeexpr_find_close_paren_ (t, + (ffelexHandler) + ffeexpr_cb_end_notloc_1_); +} + +/* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr + CLOSE_PAREN + + Should be COMMA or CLOSE_PAREN, else change back to %LOC. */ + +static ffelexHandler +ffeexpr_cb_end_notloc_1_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextACTUALARG_: + case FFEEXPR_contextSFUNCDEFACTUALARG_: + break; + + case FFEEXPR_contextINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_; + break; + + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_; + break; + + default: + assert ("bad context?!?!" == NULL); + break; + } + break; + + default: + if (ffebad_start (FFEBAD_INVALID_PERCENT)) + { + ffebad_here (0, + ffelex_token_where_line (ffeexpr_stack_->first_token), + ffelex_token_where_column (ffeexpr_stack_->first_token)); + ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1])); + ffebad_finish (); + } + + ffebld_set_op (ffeexpr_stack_->exprstack->u.operand, + FFEBLD_opPERCENT_LOC); + + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; + break; + + case FFEEXPR_contextINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; + break; + + case FFEEXPR_contextSFUNCDEFACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; + break; + + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; + break; + + default: + assert ("bad context?!?!" == NULL); + break; + } + } + + ffelex_token_kill (ffeexpr_stack_->tokens[1]); + return + (ffelexHandler) ffeexpr_token_binary_ (t); +} + +/* Process DATA implied-DO iterator variables as this implied-DO level + terminates. At this point, ffeexpr_level_ == 1 when we see the + last right-paren in "DATA (A(I),I=1,10)/.../". */ + +static ffesymbol +ffeexpr_check_impctrl_ (ffesymbol s) +{ + assert (s != NULL); + assert (ffesymbol_sfdummyparent (s) != NULL); + + switch (ffesymbol_state (s)) + { + case FFESYMBOL_stateNONE: /* Used as iterator already. Now let symbol + be used as iterator at any level at or + innermore than the outermost of the + current level and the symbol's current + level. */ + if (ffeexpr_level_ < ffesymbol_maxentrynum (s)) + { + ffesymbol_signal_change (s); + ffesymbol_set_maxentrynum (s, ffeexpr_level_); + ffesymbol_signal_unreported (s); + } + break; + + case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO. + Error if at outermost level, else it can + still become an iterator. */ + if ((ffeexpr_level_ == 1) + && ffebad_start (FFEBAD_BAD_IMPDCL)) + { + ffebad_string (ffesymbol_text (s)); + ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s)); + ffebad_finish (); + } + break; + + case FFESYMBOL_stateUNCERTAIN: /* Iterator. */ + assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s)); + ffesymbol_signal_change (s); + ffesymbol_set_state (s, FFESYMBOL_stateNONE); + ffesymbol_signal_unreported (s); + break; + + case FFESYMBOL_stateUNDERSTOOD: + break; /* ANY. */ + + default: + assert ("Sasha Foo!!" == NULL); + break; + } + + return s; +} + +/* Issue diagnostic if implied-DO variable appears in list of lhs + expressions (as in "READ *, (I,I=1,10)"). */ + +static void +ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t, + ffebld dovar, ffelexToken dovar_t) +{ + ffebld item; + ffesymbol dovar_sym; + int itemnum; + + if (ffebld_op (dovar) != FFEBLD_opSYMTER) + return; /* Presumably opANY. */ + + dovar_sym = ffebld_symter (dovar); + + for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum) + { + if (((item = ffebld_head (list)) != NULL) + && (ffebld_op (item) == FFEBLD_opSYMTER) + && (ffebld_symter (item) == dovar_sym)) + { + char itemno[20]; + + sprintf (&itemno[0], "%d", itemnum); + if (ffebad_start (FFEBAD_DOITER_IMPDO)) + { + ffebad_here (0, ffelex_token_where_line (list_t), + ffelex_token_where_column (list_t)); + ffebad_here (1, ffelex_token_where_line (dovar_t), + ffelex_token_where_column (dovar_t)); + ffebad_string (ffesymbol_text (dovar_sym)); + ffebad_string (itemno); + ffebad_finish (); + } + } + } +} + +/* Decorate any SYMTERs referencing the DO variable with the "doiter" + flag. */ + +static void +ffeexpr_update_impdo_ (ffebld list, ffebld dovar) +{ + ffesymbol dovar_sym; + + if (ffebld_op (dovar) != FFEBLD_opSYMTER) + return; /* Presumably opANY. */ + + dovar_sym = ffebld_symter (dovar); + + ffeexpr_update_impdo_sym_ (list, dovar_sym); /* Recurse! */ +} + +/* Recursive function to update any expr so SYMTERs have "doiter" flag + if they refer to the given variable. */ + +static void +ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar) +{ + tail_recurse: /* :::::::::::::::::::: */ + + if (expr == NULL) + return; + + switch (ffebld_op (expr)) + { + case FFEBLD_opSYMTER: + if (ffebld_symter (expr) == dovar) + ffebld_symter_set_is_doiter (expr, TRUE); + break; + + case FFEBLD_opITEM: + ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar); + expr = ffebld_trail (expr); + goto tail_recurse; /* :::::::::::::::::::: */ + + default: + break; + } + + switch (ffebld_arity (expr)) + { + case 2: + ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar); + expr = ffebld_right (expr); + goto tail_recurse; /* :::::::::::::::::::: */ + + case 1: + expr = ffebld_left (expr); + goto tail_recurse; /* :::::::::::::::::::: */ + + default: + break; + } + + return; +} + +/* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs + + if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF) + // After zero or more PAREN_ contexts, an IF context exists */ + +static ffeexprContext +ffeexpr_context_outer_ (ffeexprStack_ s) +{ + assert (s != NULL); + + for (;;) + { + switch (s->context) + { + case FFEEXPR_contextPAREN_: + case FFEEXPR_contextPARENFILENUM_: + case FFEEXPR_contextPARENFILEUNIT_: + break; + + default: + return s->context; + } + s = s->previous; + assert (s != NULL); + } +} + +/* ffeexpr_dotdot_ -- Look up name in list of .FOO. possibilities + + ffeexprDotdot_ d; + ffelexToken t; + d = ffeexpr_dotdot_(t); + + Returns the identifier for the name, or the NONE identifier. */ + +static ffeexprDotdot_ +ffeexpr_dotdot_ (ffelexToken t) +{ + char *p; + + switch (ffelex_token_length (t)) + { + case 2: + switch (*(p = ffelex_token_text (t))) + { + case FFESRC_CASE_MATCH_INIT ('E', 'e', match_2e, no_match_2): + if (ffesrc_char_match_noninit (*++p, 'Q', 'q')) + return FFEEXPR_dotdotEQ_; + return FFEEXPR_dotdotNONE_; + + case FFESRC_CASE_MATCH_INIT ('G', 'g', match_2g, no_match_2): + if (ffesrc_char_match_noninit (*++p, 'E', 'e')) + return FFEEXPR_dotdotGE_; + if (ffesrc_char_match_noninit (*p, 'T', 't')) + return FFEEXPR_dotdotGT_; + return FFEEXPR_dotdotNONE_; + + case FFESRC_CASE_MATCH_INIT ('L', 'l', match_2l, no_match_2): + if (ffesrc_char_match_noninit (*++p, 'E', 'e')) + return FFEEXPR_dotdotLE_; + if (ffesrc_char_match_noninit (*p, 'T', 't')) + return FFEEXPR_dotdotLT_; + return FFEEXPR_dotdotNONE_; + + case FFESRC_CASE_MATCH_INIT ('N', 'n', match_2n, no_match_2): + if (ffesrc_char_match_noninit (*++p, 'E', 'e')) + return FFEEXPR_dotdotNE_; + return FFEEXPR_dotdotNONE_; + + case FFESRC_CASE_MATCH_INIT ('O', 'o', match_2o, no_match_2): + if (ffesrc_char_match_noninit (*++p, 'R', 'r')) + return FFEEXPR_dotdotOR_; + return FFEEXPR_dotdotNONE_; + + default: + no_match_2: /* :::::::::::::::::::: */ + return FFEEXPR_dotdotNONE_; + } + + case 3: + switch (*(p = ffelex_token_text (t))) + { + case FFESRC_CASE_MATCH_INIT ('A', 'a', match_3a, no_match_3): + if ((ffesrc_char_match_noninit (*++p, 'N', 'n')) + && (ffesrc_char_match_noninit (*++p, 'D', 'd'))) + return FFEEXPR_dotdotAND_; + return FFEEXPR_dotdotNONE_; + + case FFESRC_CASE_MATCH_INIT ('E', 'e', match_3e, no_match_3): + if ((ffesrc_char_match_noninit (*++p, 'Q', 'q')) + && (ffesrc_char_match_noninit (*++p, 'V', 'v'))) + return FFEEXPR_dotdotEQV_; + return FFEEXPR_dotdotNONE_; + + case FFESRC_CASE_MATCH_INIT ('N', 'n', match_3n, no_match_3): + if ((ffesrc_char_match_noninit (*++p, 'O', 'o')) + && (ffesrc_char_match_noninit (*++p, 'T', 't'))) + return FFEEXPR_dotdotNOT_; + return FFEEXPR_dotdotNONE_; + + case FFESRC_CASE_MATCH_INIT ('X', 'x', match_3x, no_match_3): + if ((ffesrc_char_match_noninit (*++p, 'O', 'o')) + && (ffesrc_char_match_noninit (*++p, 'R', 'r'))) + return FFEEXPR_dotdotXOR_; + return FFEEXPR_dotdotNONE_; + + default: + no_match_3: /* :::::::::::::::::::: */ + return FFEEXPR_dotdotNONE_; + } + + case 4: + switch (*(p = ffelex_token_text (t))) + { + case FFESRC_CASE_MATCH_INIT ('N', 'n', match_4n, no_match_4): + if ((ffesrc_char_match_noninit (*++p, 'E', 'e')) + && (ffesrc_char_match_noninit (*++p, 'Q', 'q')) + && (ffesrc_char_match_noninit (*++p, 'V', 'v'))) + return FFEEXPR_dotdotNEQV_; + return FFEEXPR_dotdotNONE_; + + case FFESRC_CASE_MATCH_INIT ('T', 't', match_4t, no_match_4): + if ((ffesrc_char_match_noninit (*++p, 'R', 'r')) + && (ffesrc_char_match_noninit (*++p, 'U', 'u')) + && (ffesrc_char_match_noninit (*++p, 'E', 'e'))) + return FFEEXPR_dotdotTRUE_; + return FFEEXPR_dotdotNONE_; + + default: + no_match_4: /* :::::::::::::::::::: */ + return FFEEXPR_dotdotNONE_; + } + + case 5: + if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "FALSE", + "false", "False") + == 0) + return FFEEXPR_dotdotFALSE_; + return FFEEXPR_dotdotNONE_; + + default: + return FFEEXPR_dotdotNONE_; + } +} + +/* ffeexpr_percent_ -- Look up name in list of %FOO possibilities + + ffeexprPercent_ p; + ffelexToken t; + p = ffeexpr_percent_(t); + + Returns the identifier for the name, or the NONE identifier. */ + +static ffeexprPercent_ +ffeexpr_percent_ (ffelexToken t) +{ + char *p; + + switch (ffelex_token_length (t)) + { + case 3: + switch (*(p = ffelex_token_text (t))) + { + case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3): + if ((ffesrc_char_match_noninit (*++p, 'O', 'o')) + && (ffesrc_char_match_noninit (*++p, 'C', 'c'))) + return FFEEXPR_percentLOC_; + return FFEEXPR_percentNONE_; + + case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3): + if ((ffesrc_char_match_noninit (*++p, 'E', 'e')) + && (ffesrc_char_match_noninit (*++p, 'F', 'f'))) + return FFEEXPR_percentREF_; + return FFEEXPR_percentNONE_; + + case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3): + if ((ffesrc_char_match_noninit (*++p, 'A', 'a')) + && (ffesrc_char_match_noninit (*++p, 'L', 'l'))) + return FFEEXPR_percentVAL_; + return FFEEXPR_percentNONE_; + + default: + no_match_3: /* :::::::::::::::::::: */ + return FFEEXPR_percentNONE_; + } + + case 5: + if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR", + "descr", "Descr") == 0) + return FFEEXPR_percentDESCR_; + return FFEEXPR_percentNONE_; + + default: + return FFEEXPR_percentNONE_; + } +} + +/* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX + + See prototype. + + If combining the two basictype/kindtype pairs produces a COMPLEX with an + unsupported kind type, complain and use the default kind type for + COMPLEX. */ + +void +ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt, + ffeinfoBasictype lbt, ffeinfoKindtype lkt, + ffeinfoBasictype rbt, ffeinfoKindtype rkt, + ffelexToken t) +{ + ffeinfoBasictype nbt; + ffeinfoKindtype nkt; + + nbt = ffeinfo_basictype_combine (lbt, rbt); + if ((nbt == FFEINFO_basictypeCOMPLEX) + && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL)) + && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL))) + { + nkt = ffeinfo_kindtype_max (nbt, lkt, rkt); + if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE)) + nkt = FFEINFO_kindtypeNONE; /* Force error. */ + switch (nkt) + { +#if FFETARGET_okCOMPLEX1 + case FFEINFO_kindtypeREAL1: +#endif +#if FFETARGET_okCOMPLEX2 + case FFEINFO_kindtypeREAL2: +#endif +#if FFETARGET_okCOMPLEX3 + case FFEINFO_kindtypeREAL3: +#endif +#if FFETARGET_okCOMPLEX4 + case FFEINFO_kindtypeREAL4: +#endif + break; /* Fine and dandy. */ + + default: + if (t != NULL) + { + ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE) + ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + nbt = FFEINFO_basictypeNONE; + nkt = FFEINFO_kindtypeNONE; + break; + + case FFEINFO_kindtypeANY: + nkt = FFEINFO_kindtypeREALDEFAULT; + break; + } + } + else + { /* The normal stuff. */ + if (nbt == lbt) + if (nbt == rbt) + nkt = ffeinfo_kindtype_max (nbt, lkt, rkt); + else + nkt = lkt; + else if (nbt == rbt) + nkt = rkt; + else + { /* Let the caller do the complaining. */ + nbt = FFEINFO_basictypeNONE; + nkt = FFEINFO_kindtypeNONE; + } + } + + /* Always a good idea to avoid aliasing problems. */ + + *xnbt = nbt; + *xnkt = nkt; +} + +/* ffeexpr_token_first_lhs_ -- First state for lhs expression + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Record line and column of first token in expression, then invoke the + initial-state lhs handler. */ + +static ffelexHandler +ffeexpr_token_first_lhs_ (ffelexToken t) +{ + ffeexpr_stack_->first_token = ffelex_token_use (t); + + /* When changing the list of valid initial lhs tokens, check whether to + update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the + READ (expr) case -- it assumes it knows which tokens can + be to indicate an lhs (or implied DO), which right now is the set + {NAME,OPEN_PAREN}. + + This comment also appears in ffeexpr_token_lhs_. */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextDATA: + ffe_init_4 (); + ffeexpr_level_ = 1; /* Level of DATA implied-DO construct. */ + ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); + return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool, + FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_); + + case FFEEXPR_contextDATAIMPDOITEM_: + ++ffeexpr_level_; /* Level of DATA implied-DO construct. */ + ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); + return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool, + FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_); + + case FFEEXPR_contextIOLIST: + case FFEEXPR_contextIMPDOITEM_: + ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); + return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool, + FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_); + + case FFEEXPR_contextIOLISTDF: + case FFEEXPR_contextIMPDOITEMDF_: + ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); + return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool, + FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_); + + case FFEEXPR_contextFILEEXTFUNC: + assert (ffeexpr_stack_->exprstack == NULL); + return (ffelexHandler) ffeexpr_token_first_lhs_1_; + + default: + break; + } + break; + + case FFELEX_typeNAME: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextFILENAMELIST: + assert (ffeexpr_stack_->exprstack == NULL); + return (ffelexHandler) ffeexpr_token_namelist_; + + case FFEEXPR_contextFILEEXTFUNC: + assert (ffeexpr_stack_->exprstack == NULL); + return (ffelexHandler) ffeexpr_token_first_lhs_1_; + + default: + break; + } + break; + + default: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextFILEEXTFUNC: + assert (ffeexpr_stack_->exprstack == NULL); + return (ffelexHandler) ffeexpr_token_first_lhs_1_; + + default: + break; + } + break; + } + + return (ffelexHandler) ffeexpr_token_lhs_ (t); +} + +/* ffeexpr_token_first_lhs_1_ -- NAME + + return ffeexpr_token_first_lhs_1_; // to lexer + + Handle NAME as an external function (USEROPEN= VXT extension to OPEN + statement). */ + +static ffelexHandler +ffeexpr_token_first_lhs_1_ (ffelexToken t) +{ + ffeexprCallback callback; + ffeexprStack_ s; + ffelexHandler next; + ffelexToken ft; + ffesymbol sy = NULL; + ffebld expr; + + ffebld_pool_pop (); + callback = ffeexpr_stack_->callback; + ft = ffeexpr_stack_->first_token; + s = ffeexpr_stack_->previous; + + if ((ffelex_token_type (ft) != FFELEX_typeNAME) + || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE)) + & FFESYMBOL_attrANY)) + { + if ((ffelex_token_type (ft) != FFELEX_typeNAME) + || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY)) + { + ffebad_start (FFEBAD_EXPR_WRONG); + ffebad_here (0, ffelex_token_where_line (ft), + ffelex_token_where_column (ft)); + ffebad_finish (); + } + expr = ffebld_new_any (); + ffebld_set_info (expr, ffeinfo_new_any ()); + } + else + { + expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE, + FFEINTRIN_impNONE); + ffebld_set_info (expr, ffesymbol_info (sy)); + } + + malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, + sizeof (*ffeexpr_stack_)); + ffeexpr_stack_ = s; + + next = (ffelexHandler) (*callback) (ft, expr, t); + ffelex_token_kill (ft); + return (ffelexHandler) next; +} + +/* ffeexpr_token_first_rhs_ -- First state for rhs expression + + Record line and column of first token in expression, then invoke the + initial-state rhs handler. + + 19-Feb-91 JCB 1.1 + Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only + (i.e. only as in READ(*), not READ((*))). */ + +static ffelexHandler +ffeexpr_token_first_rhs_ (ffelexToken t) +{ + ffesymbol s; + + ffeexpr_stack_->first_token = ffelex_token_use (t); + + switch (ffelex_token_type (t)) + { + case FFELEX_typeASTERISK: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextFILEFORMATNML: + ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; + /* Fall through. */ + case FFEEXPR_contextFILEUNIT: + case FFEEXPR_contextDIMLIST: + case FFEEXPR_contextFILEFORMAT: + case FFEEXPR_contextCHARACTERSIZE: + if (ffeexpr_stack_->previous != NULL) + break; /* Valid only on first level. */ + assert (ffeexpr_stack_->exprstack == NULL); + return (ffelexHandler) ffeexpr_token_first_rhs_1_; + + case FFEEXPR_contextPARENFILEUNIT_: + if (ffeexpr_stack_->previous->previous != NULL) + break; /* Valid only on second level. */ + assert (ffeexpr_stack_->exprstack == NULL); + return (ffelexHandler) ffeexpr_token_first_rhs_1_; + + case FFEEXPR_contextACTUALARG_: + if (ffeexpr_stack_->previous->context + != FFEEXPR_contextSUBROUTINEREF) + { + ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; + break; + } + assert (ffeexpr_stack_->exprstack == NULL); + return (ffelexHandler) ffeexpr_token_first_rhs_3_; + + case FFEEXPR_contextINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; + break; + + case FFEEXPR_contextSFUNCDEFACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; + break; + + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; + break; + + default: + break; + } + break; + + case FFELEX_typeOPEN_PAREN: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextFILENUMAMBIG: + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextPARENFILENUM_, + ffeexpr_cb_close_paren_ambig_); + + case FFEEXPR_contextFILEUNITAMBIG: + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextPARENFILEUNIT_, + ffeexpr_cb_close_paren_ambig_); + + case FFEEXPR_contextIOLIST: + case FFEEXPR_contextIMPDOITEM_: + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextIMPDOITEM_, + ffeexpr_cb_close_paren_ci_); + + case FFEEXPR_contextIOLISTDF: + case FFEEXPR_contextIMPDOITEMDF_: + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextIMPDOITEMDF_, + ffeexpr_cb_close_paren_ci_); + + case FFEEXPR_contextFILEFORMATNML: + ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; + break; + + case FFEEXPR_contextACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; + break; + + case FFEEXPR_contextINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; + break; + + case FFEEXPR_contextSFUNCDEFACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; + break; + + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; + break; + + default: + break; + } + break; + + case FFELEX_typeNUMBER: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextFILEFORMATNML: + ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; + /* Fall through. */ + case FFEEXPR_contextFILEFORMAT: + if (ffeexpr_stack_->previous != NULL) + break; /* Valid only on first level. */ + assert (ffeexpr_stack_->exprstack == NULL); + return (ffelexHandler) ffeexpr_token_first_rhs_2_; + + case FFEEXPR_contextACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; + break; + + case FFEEXPR_contextINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; + break; + + case FFEEXPR_contextSFUNCDEFACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; + break; + + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; + break; + + default: + break; + } + break; + + case FFELEX_typeNAME: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextFILEFORMATNML: + assert (ffeexpr_stack_->exprstack == NULL); + s = ffesymbol_lookup_local (t); + if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST)) + return (ffelexHandler) ffeexpr_token_namelist_; + ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; + break; + + default: + break; + } + break; + + case FFELEX_typePERCENT: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextACTUALARG_: + case FFEEXPR_contextINDEXORACTUALARG_: + case FFEEXPR_contextSFUNCDEFACTUALARG_: + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + return (ffelexHandler) ffeexpr_token_first_rhs_5_; + + case FFEEXPR_contextFILEFORMATNML: + ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; + break; + + default: + break; + } + + default: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; + break; + + case FFEEXPR_contextINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; + break; + + case FFEEXPR_contextSFUNCDEFACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; + break; + + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; + break; + + case FFEEXPR_contextFILEFORMATNML: + ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT; + break; + + default: + break; + } + break; + } + + return (ffelexHandler) ffeexpr_token_rhs_ (t); +} + +/* ffeexpr_token_first_rhs_1_ -- ASTERISK + + return ffeexpr_token_first_rhs_1_; // to lexer + + Return STAR as expression. */ + +static ffelexHandler +ffeexpr_token_first_rhs_1_ (ffelexToken t) +{ + ffebld expr; + ffeexprCallback callback; + ffeexprStack_ s; + ffelexHandler next; + ffelexToken ft; + + expr = ffebld_new_star (); + ffebld_pool_pop (); + callback = ffeexpr_stack_->callback; + ft = ffeexpr_stack_->first_token; + s = ffeexpr_stack_->previous; + malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); + ffeexpr_stack_ = s; + next = (ffelexHandler) (*callback) (ft, expr, t); + ffelex_token_kill (ft); + return (ffelexHandler) next; +} + +/* ffeexpr_token_first_rhs_2_ -- NUMBER + + return ffeexpr_token_first_rhs_2_; // to lexer + + Return NULL as expression; NUMBER as first (and only) token, unless the + current token is not a terminating token, in which case run normal + expression handling. */ + +static ffelexHandler +ffeexpr_token_first_rhs_2_ (ffelexToken t) +{ + ffeexprCallback callback; + ffeexprStack_ s; + ffelexHandler next; + ffelexToken ft; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + case FFELEX_typeCOMMA: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + + default: + next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token); + return (ffelexHandler) (*next) (t); + } + + ffebld_pool_pop (); + callback = ffeexpr_stack_->callback; + ft = ffeexpr_stack_->first_token; + s = ffeexpr_stack_->previous; + malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, + sizeof (*ffeexpr_stack_)); + ffeexpr_stack_ = s; + next = (ffelexHandler) (*callback) (ft, NULL, t); + ffelex_token_kill (ft); + return (ffelexHandler) next; +} + +/* ffeexpr_token_first_rhs_3_ -- ASTERISK + + return ffeexpr_token_first_rhs_3_; // to lexer + + Expect NUMBER, make LABTOK (with copy of token if not inhibited after + confirming, else NULL). */ + +static ffelexHandler +ffeexpr_token_first_rhs_3_ (ffelexToken t) +{ + ffelexHandler next; + + if (ffelex_token_type (t) != FFELEX_typeNUMBER) + { /* An error, but let normal processing handle + it. */ + next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token); + return (ffelexHandler) (*next) (t); + } + + /* Special case: when we see "*10" as an argument to a subroutine + reference, we confirm the current statement and, if not inhibited at + this point, put a copy of the token into a LABTOK node. We do this + instead of just resolving the label directly via ffelab and putting it + into a LABTER simply to improve error reporting and consistency in + ffestc. We put NULL in the LABTOK if we're still inhibited, so ffestb + doesn't have to worry about killing off any tokens when retracting. */ + + ffest_confirmed (); + if (ffest_is_inhibited ()) + ffeexpr_stack_->expr = ffebld_new_labtok (NULL); + else + ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t)); + ffebld_set_info (ffeexpr_stack_->expr, + ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, + 0, + FFEINFO_kindNONE, + FFEINFO_whereNONE, + FFETARGET_charactersizeNONE)); + + return (ffelexHandler) ffeexpr_token_first_rhs_4_; +} + +/* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER + + return ffeexpr_token_first_rhs_4_; // to lexer + + Collect/flush appropriate stuff, send token to callback function. */ + +static ffelexHandler +ffeexpr_token_first_rhs_4_ (ffelexToken t) +{ + ffebld expr; + ffeexprCallback callback; + ffeexprStack_ s; + ffelexHandler next; + ffelexToken ft; + + expr = ffeexpr_stack_->expr; + ffebld_pool_pop (); + callback = ffeexpr_stack_->callback; + ft = ffeexpr_stack_->first_token; + s = ffeexpr_stack_->previous; + malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); + ffeexpr_stack_ = s; + next = (ffelexHandler) (*callback) (ft, expr, t); + ffelex_token_kill (ft); + return (ffelexHandler) next; +} + +/* ffeexpr_token_first_rhs_5_ -- PERCENT + + Should be NAME, or pass through original mechanism. If NAME is LOC, + pass through original mechanism, otherwise must be VAL, REF, or DESCR, + in which case handle the argument (in parentheses), etc. */ + +static ffelexHandler +ffeexpr_token_first_rhs_5_ (ffelexToken t) +{ + ffelexHandler next; + + if (ffelex_token_type (t) == FFELEX_typeNAME) + { + ffeexprPercent_ p = ffeexpr_percent_ (t); + + switch (p) + { + case FFEEXPR_percentNONE_: + case FFEEXPR_percentLOC_: + break; /* Treat %LOC as any other expression. */ + + case FFEEXPR_percentVAL_: + case FFEEXPR_percentREF_: + case FFEEXPR_percentDESCR_: + ffeexpr_stack_->percent = p; + ffeexpr_stack_->tokens[0] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_first_rhs_6_; + + default: + assert ("bad percent?!?" == NULL); + break; + } + } + + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; + break; + + case FFEEXPR_contextINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; + break; + + case FFEEXPR_contextSFUNCDEFACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; + break; + + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; + break; + + default: + assert ("bad context?!?!" == NULL); + break; + } + + next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token); + return (ffelexHandler) (*next) (t); +} + +/* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR) + + Should be OPEN_PAREN, or pass through original mechanism. */ + +static ffelexHandler +ffeexpr_token_first_rhs_6_ (ffelexToken t) +{ + ffelexHandler next; + ffelexToken ft; + + if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN) + { + ffeexpr_stack_->tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + ffeexpr_stack_->context, + ffeexpr_cb_end_notloc_); + } + + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; + break; + + case FFEEXPR_contextINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; + break; + + case FFEEXPR_contextSFUNCDEFACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; + break; + + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; + break; + + default: + assert ("bad context?!?!" == NULL); + break; + } + + ft = ffeexpr_stack_->tokens[0]; + next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token); + next = (ffelexHandler) (*next) (ft); + ffelex_token_kill (ft); + return (ffelexHandler) (*next) (t); +} + +/* ffeexpr_token_namelist_ -- NAME + + return ffeexpr_token_namelist_; // to lexer + + Make sure NAME was a valid namelist object, wrap it in a SYMTER and + return. */ + +static ffelexHandler +ffeexpr_token_namelist_ (ffelexToken t) +{ + ffeexprCallback callback; + ffeexprStack_ s; + ffelexHandler next; + ffelexToken ft; + ffesymbol sy; + ffebld expr; + + ffebld_pool_pop (); + callback = ffeexpr_stack_->callback; + ft = ffeexpr_stack_->first_token; + s = ffeexpr_stack_->previous; + malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_)); + ffeexpr_stack_ = s; + + sy = ffesymbol_lookup_local (ft); + if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST)) + { + ffebad_start (FFEBAD_EXPR_WRONG); + ffebad_here (0, ffelex_token_where_line (ft), + ffelex_token_where_column (ft)); + ffebad_finish (); + expr = ffebld_new_any (); + ffebld_set_info (expr, ffeinfo_new_any ()); + } + else + { + expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE, + FFEINTRIN_impNONE); + ffebld_set_info (expr, ffesymbol_info (sy)); + } + next = (ffelexHandler) (*callback) (ft, expr, t); + ffelex_token_kill (ft); + return (ffelexHandler) next; +} + +/* ffeexpr_expr_kill_ -- Kill an existing internal expression object + + ffeexprExpr_ e; + ffeexpr_expr_kill_(e); + + Kills the ffewhere info, if necessary, then kills the object. */ + +static void +ffeexpr_expr_kill_ (ffeexprExpr_ e) +{ + if (e->token != NULL) + ffelex_token_kill (e->token); + malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e)); +} + +/* ffeexpr_expr_new_ -- Make a new internal expression object + + ffeexprExpr_ e; + e = ffeexpr_expr_new_(); + + Allocates and initializes a new expression object, returns it. */ + +static ffeexprExpr_ +ffeexpr_expr_new_ () +{ + ffeexprExpr_ e; + + e = (ffeexprExpr_) malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr", + sizeof (*e)); + e->previous = NULL; + e->type = FFEEXPR_exprtypeUNKNOWN_; + e->token = NULL; + return e; +} + +/* Verify that call to global is valid, and register whatever + new information about a global might be discoverable by looking + at the call. */ + +static void +ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t) +{ + int n_args; + ffebld list; + ffebld item; + ffesymbol s; + + assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF) + || (ffebld_op (*expr) == FFEBLD_opFUNCREF)); + + if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER) + return; + + if (ffesymbol_retractable ()) + return; + + s = ffebld_symter (ffebld_left (*expr)); + if (ffesymbol_global (s) == NULL) + return; + + for (n_args = 0, list = ffebld_right (*expr); + list != NULL; + list = ffebld_trail (list), ++n_args) + ; + + if (ffeglobal_proc_ref_nargs (s, n_args, t)) + { + ffeglobalArgSummary as; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + bool array; + bool fail = FALSE; + + for (n_args = 0, list = ffebld_right (*expr); + list != NULL; + list = ffebld_trail (list), ++n_args) + { + item = ffebld_head (list); + if (item != NULL) + { + bt = ffeinfo_basictype (ffebld_info (item)); + kt = ffeinfo_kindtype (ffebld_info (item)); + array = (ffeinfo_rank (ffebld_info (item)) > 0); + switch (ffebld_op (item)) + { + case FFEBLD_opLABTOK: + case FFEBLD_opLABTER: + as = FFEGLOBAL_argsummaryALTRTN; + break; + + case FFEBLD_opPERCENT_LOC: + as = FFEGLOBAL_argsummaryPTR; + break; + + case FFEBLD_opPERCENT_VAL: + as = FFEGLOBAL_argsummaryVAL; + break; + + case FFEBLD_opPERCENT_REF: + as = FFEGLOBAL_argsummaryREF; + break; + + case FFEBLD_opPERCENT_DESCR: + as = FFEGLOBAL_argsummaryDESCR; + break; + + case FFEBLD_opFUNCREF: + if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER) + && (ffesymbol_specific (ffebld_symter (ffebld_left (item))) + == FFEINTRIN_specLOC)) + { + as = FFEGLOBAL_argsummaryPTR; + break; + } + /* Fall through. */ + default: + if (ffebld_op (item) == FFEBLD_opSYMTER) + { + as = FFEGLOBAL_argsummaryNONE; + + switch (ffeinfo_kind (ffebld_info (item))) + { + case FFEINFO_kindFUNCTION: + as = FFEGLOBAL_argsummaryFUNC; + break; + + case FFEINFO_kindSUBROUTINE: + as = FFEGLOBAL_argsummarySUBR; + break; + + case FFEINFO_kindNONE: + as = FFEGLOBAL_argsummaryPROC; + break; + + default: + break; + } + + if (as != FFEGLOBAL_argsummaryNONE) + break; + } + + if (bt == FFEINFO_basictypeCHARACTER) + as = FFEGLOBAL_argsummaryDESCR; + else + as = FFEGLOBAL_argsummaryREF; + break; + } + } + else + { + array = FALSE; + as = FFEGLOBAL_argsummaryNONE; + bt = FFEINFO_basictypeNONE; + kt = FFEINFO_kindtypeNONE; + } + + if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t)) + fail = TRUE; + } + if (! fail) + return; + } + + *expr = ffebld_new_any (); + ffebld_set_info (*expr, ffeinfo_new_any ()); +} + +/* Check whether rest of string is all decimal digits. */ + +static bool +ffeexpr_isdigits_ (char *p) +{ + for (; *p != '\0'; ++p) + if (!isdigit (*p)) + return FALSE; + return TRUE; +} + +/* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack + + ffeexprExpr_ e; + ffeexpr_exprstack_push_(e); + + Pushes the expression onto the stack without any analysis of the existing + contents of the stack. */ + +static void +ffeexpr_exprstack_push_ (ffeexprExpr_ e) +{ + e->previous = ffeexpr_stack_->exprstack; + ffeexpr_stack_->exprstack = e; +} + +/* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce? + + ffeexprExpr_ e; + ffeexpr_exprstack_push_operand_(e); + + Pushes the expression already containing an operand (a constant, variable, + or more complicated expression that has already been fully resolved) after + analyzing the stack and checking for possible reduction (which will never + happen here since the highest precedence operator is ** and it has right- + to-left associativity). */ + +static void +ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e) +{ + ffeexpr_exprstack_push_ (e); +#ifdef WEIRD_NONFORTRAN_RULES + if ((ffeexpr_stack_->exprstack != NULL) + && (ffeexpr_stack_->exprstack->expr->type == FFEEXPR_exprtypeBINARY_) + && (ffeexpr_stack_->exprstack->expr->u.operator.prec + == FFEEXPR_operatorprecedenceHIGHEST_) + && (ffeexpr_stack_->exprstack->expr->u.operator.as + == FFEEXPR_operatorassociativityL2R_)) + ffeexpr_reduce_ (); +#endif +} + +/* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack + + ffeexprExpr_ e; + ffeexpr_exprstack_push_unary_(e); + + Pushes the expression already containing a unary operator. Reduction can + never happen since unary operators are themselves always R-L; that is, the + top of the expression stack is not an operand, in that it is either empty, + has a binary operator at the top, or a unary operator at the top. In any + of these cases, reduction is impossible. */ + +static void +ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e) +{ + if ((ffe_is_pedantic () + || ffe_is_warn_surprising ()) + && (ffeexpr_stack_->exprstack != NULL) + && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_) + && (ffeexpr_stack_->exprstack->u.operator.prec + <= FFEEXPR_operatorprecedenceLOWARITH_) + && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_)) + { + ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses", + ffe_is_pedantic () + ? FFEBAD_severityPEDANTIC + : FFEBAD_severityWARNING); + ffebad_here (0, + ffelex_token_where_line (ffeexpr_stack_->exprstack->token), + ffelex_token_where_column (ffeexpr_stack_->exprstack->token)); + ffebad_here (1, + ffelex_token_where_line (e->token), + ffelex_token_where_column (e->token)); + ffebad_finish (); + } + + ffeexpr_exprstack_push_ (e); +} + +/* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce? + + ffeexprExpr_ e; + ffeexpr_exprstack_push_binary_(e); + + Pushes the expression already containing a binary operator after checking + whether reduction is possible. If the stack is not empty, the top of the + stack must be an operand or syntactic analysis has failed somehow. If + the operand is preceded by a unary operator of higher (or equal and L-R + associativity) precedence than the new binary operator, then reduce that + preceding operator and its operand(s) before pushing the new binary + operator. */ + +static void +ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e) +{ + ffeexprExpr_ ce; + + if (ffe_is_warn_surprising () + /* These next two are always true (see assertions below). */ + && (ffeexpr_stack_->exprstack != NULL) + && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_) + /* If the previous operator is a unary minus, and the binary op + is of higher precedence, might not do what user expects, + e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would + yield "4". */ + && (ffeexpr_stack_->exprstack->previous != NULL) + && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_) + && (ffeexpr_stack_->exprstack->previous->u.operator.op + == FFEEXPR_operatorSUBTRACT_) + && (e->u.operator.prec + < ffeexpr_stack_->exprstack->previous->u.operator.prec)) + { + ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING); + ffebad_here (0, + ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token), + ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token)); + ffebad_here (1, + ffelex_token_where_line (e->token), + ffelex_token_where_column (e->token)); + ffebad_finish (); + } + +again: + assert (ffeexpr_stack_->exprstack != NULL); + assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_); + if ((ce = ffeexpr_stack_->exprstack->previous) != NULL) + { + assert (ce->type != FFEEXPR_exprtypeOPERAND_); + if ((ce->u.operator.prec < e->u.operator.prec) + || ((ce->u.operator.prec == e->u.operator.prec) + && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_))) + { + ffeexpr_reduce_ (); + goto again; /* :::::::::::::::::::: */ + } + } + + ffeexpr_exprstack_push_ (e); +} + +/* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack + + ffeexpr_reduce_(); + + Converts operand binop operand or unop operand at top of stack to a + single operand having the appropriate ffebld expression, and makes + sure that the expression is proper (like not trying to add two character + variables, not trying to concatenate two numbers). Also does the + requisite type-assignment. */ + +static void +ffeexpr_reduce_ () +{ + ffeexprExpr_ operand; /* This is B in -B or A+B. */ + ffeexprExpr_ left_operand; /* When operator is binary, this is A in A+B. */ + ffeexprExpr_ operator; /* This is + in A+B. */ + ffebld reduced; /* This is +(A,B) in A+B or u-(B) in -B. */ + ffebldConstant constnode; /* For checking magical numbers (where mag == + -mag). */ + ffebld expr; + ffebld left_expr; + bool submag = FALSE; + + operand = ffeexpr_stack_->exprstack; + assert (operand != NULL); + assert (operand->type == FFEEXPR_exprtypeOPERAND_); + operator = operand->previous; + assert (operator != NULL); + assert (operator->type != FFEEXPR_exprtypeOPERAND_); + if (operator->type == FFEEXPR_exprtypeUNARY_) + { + expr = operand->u.operand; + switch (operator->u.operator.op) + { + case FFEEXPR_operatorADD_: + reduced = ffebld_new_uplus (expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand); + reduced = ffeexpr_reduced_math1_ (reduced, operator, operand); + reduced = ffeexpr_collapse_uplus (reduced, operator->token); + break; + + case FFEEXPR_operatorSUBTRACT_: + submag = TRUE; /* Ok to negate a magic number. */ + reduced = ffebld_new_uminus (expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand); + reduced = ffeexpr_reduced_math1_ (reduced, operator, operand); + reduced = ffeexpr_collapse_uminus (reduced, operator->token); + break; + + case FFEEXPR_operatorNOT_: + reduced = ffebld_new_not (expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand); + reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand); + reduced = ffeexpr_collapse_not (reduced, operator->token); + break; + + default: + assert ("unexpected unary op" != NULL); + reduced = NULL; + break; + } + if (!submag + && (ffebld_op (expr) == FFEBLD_opCONTER) + && (ffebld_conter_orig (expr) == NULL) + && ffebld_constant_is_magical (constnode = ffebld_conter (expr))) + { + ffetarget_integer_bad_magical (operand->token); + } + ffeexpr_stack_->exprstack = operator->previous; /* Pops unary-op operand + off stack. */ + ffeexpr_expr_kill_ (operand); + operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but + save */ + operator->u.operand = reduced; /* the line/column ffewhere info. */ + ffeexpr_exprstack_push_operand_ (operator); /* Push it back on + stack. */ + } + else + { + assert (operator->type == FFEEXPR_exprtypeBINARY_); + left_operand = operator->previous; + assert (left_operand != NULL); + assert (left_operand->type == FFEEXPR_exprtypeOPERAND_); + expr = operand->u.operand; + left_expr = left_operand->u.operand; + switch (operator->u.operator.op) + { + case FFEEXPR_operatorADD_: + reduced = ffebld_new_add (left_expr, expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_collapse_add (reduced, operator->token); + break; + + case FFEEXPR_operatorSUBTRACT_: + submag = TRUE; /* Just to pick the right error if magic + number. */ + reduced = ffebld_new_subtract (left_expr, expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_collapse_subtract (reduced, operator->token); + break; + + case FFEEXPR_operatorMULTIPLY_: + reduced = ffebld_new_multiply (left_expr, expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_collapse_multiply (reduced, operator->token); + break; + + case FFEEXPR_operatorDIVIDE_: + reduced = ffebld_new_divide (left_expr, expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_collapse_divide (reduced, operator->token); + break; + + case FFEEXPR_operatorPOWER_: + reduced = ffebld_new_power (left_expr, expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_collapse_power (reduced, operator->token); + break; + + case FFEEXPR_operatorCONCATENATE_: + reduced = ffebld_new_concatenate (left_expr, expr); + reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_collapse_concatenate (reduced, operator->token); + break; + + case FFEEXPR_operatorLT_: + reduced = ffebld_new_lt (left_expr, expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_collapse_lt (reduced, operator->token); + break; + + case FFEEXPR_operatorLE_: + reduced = ffebld_new_le (left_expr, expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_collapse_le (reduced, operator->token); + break; + + case FFEEXPR_operatorEQ_: + reduced = ffebld_new_eq (left_expr, expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_collapse_eq (reduced, operator->token); + break; + + case FFEEXPR_operatorNE_: + reduced = ffebld_new_ne (left_expr, expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_collapse_ne (reduced, operator->token); + break; + + case FFEEXPR_operatorGT_: + reduced = ffebld_new_gt (left_expr, expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_collapse_gt (reduced, operator->token); + break; + + case FFEEXPR_operatorGE_: + reduced = ffebld_new_ge (left_expr, expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_collapse_ge (reduced, operator->token); + break; + + case FFEEXPR_operatorAND_: + reduced = ffebld_new_and (left_expr, expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_collapse_and (reduced, operator->token); + break; + + case FFEEXPR_operatorOR_: + reduced = ffebld_new_or (left_expr, expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_collapse_or (reduced, operator->token); + break; + + case FFEEXPR_operatorXOR_: + reduced = ffebld_new_xor (left_expr, expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_collapse_xor (reduced, operator->token); + break; + + case FFEEXPR_operatorEQV_: + reduced = ffebld_new_eqv (left_expr, expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_collapse_eqv (reduced, operator->token); + break; + + case FFEEXPR_operatorNEQV_: + reduced = ffebld_new_neqv (left_expr, expr); + if (ffe_is_ugly_logint ()) + reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator, + operand); + reduced = ffeexpr_collapse_neqv (reduced, operator->token); + break; + + default: + assert ("bad bin op" == NULL); + reduced = expr; + break; + } + if ((ffebld_op (left_expr) == FFEBLD_opCONTER) + && (ffebld_conter_orig (expr) == NULL) + && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr))) + { + if ((left_operand->previous != NULL) + && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_) + && (left_operand->previous->u.operator.op + == FFEEXPR_operatorSUBTRACT_)) + if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_) + ffetarget_integer_bad_magical_precedence (left_operand->token, + left_operand->previous->token, + operator->token); + else + ffetarget_integer_bad_magical_precedence_binary + (left_operand->token, + left_operand->previous->token, + operator->token); + else + ffetarget_integer_bad_magical (left_operand->token); + } + if ((ffebld_op (expr) == FFEBLD_opCONTER) + && (ffebld_conter_orig (expr) == NULL) + && ffebld_constant_is_magical (constnode = ffebld_conter (expr))) + if (submag) + ffetarget_integer_bad_magical_binary (operand->token, + operator->token); + else + ffetarget_integer_bad_magical (operand->token); + ffeexpr_stack_->exprstack = left_operand->previous; /* Pops binary-op + operands off stack. */ + ffeexpr_expr_kill_ (left_operand); + ffeexpr_expr_kill_ (operand); + operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but + save */ + operator->u.operand = reduced; /* the line/column ffewhere info. */ + ffeexpr_exprstack_push_operand_ (operator); /* Push it back on + stack. */ + } +} + +/* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator + + reduced = ffeexpr_reduced_bool1_(reduced,op,r); + + Makes sure the argument for reduced has basictype of + LOGICAL or (ugly) INTEGER. If + argument has where of CONSTANT, assign where CONSTANT to + reduced, else assign where FLEETING. + + If these requirements cannot be met, generate error message. */ + +static ffebld +ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r) +{ + ffeinfo rinfo, ninfo; + ffeinfoBasictype rbt; + ffeinfoKindtype rkt; + ffeinfoRank rrk; + ffeinfoKind rkd; + ffeinfoWhere rwh, nwh; + + rinfo = ffebld_info (ffebld_left (reduced)); + rbt = ffeinfo_basictype (rinfo); + rkt = ffeinfo_kindtype (rinfo); + rrk = ffeinfo_rank (rinfo); + rkd = ffeinfo_kind (rinfo); + rwh = ffeinfo_where (rinfo); + + if (((rbt == FFEINFO_basictypeLOGICAL) + || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER))) + && (rrk == 0)) + { + switch (rwh) + { + case FFEINFO_whereCONSTANT: + nwh = FFEINFO_whereCONSTANT; + break; + + case FFEINFO_whereIMMEDIATE: + nwh = FFEINFO_whereIMMEDIATE; + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + + ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh, + FFETARGET_charactersizeNONE); + ffebld_set_info (reduced, ninfo); + return reduced; + } + + if ((rbt != FFEINFO_basictypeLOGICAL) + && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER))) + { + if ((rbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_NOT_ARG_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_finish (); + } + } + else + { + if ((rkd != FFEINFO_kindANY) + && ffebad_start (FFEBAD_NOT_ARG_KIND)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_string ("an array"); + ffebad_finish (); + } + } + + reduced = ffebld_new_any (); + ffebld_set_info (reduced, ffeinfo_new_any ()); + return reduced; +} + +/* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators + + reduced = ffeexpr_reduced_bool2_(reduced,l,op,r); + + Makes sure the left and right arguments for reduced have basictype of + LOGICAL or (ugly) INTEGER. Determine common basictype and + size for reduction (flag expression for combined hollerith/typeless + situations for later determination of effective basictype). If both left + and right arguments have where of CONSTANT, assign where CONSTANT to + reduced, else assign where FLEETING. Create CONVERT ops for args where + needed. Convert typeless + constants to the desired type/size explicitly. + + If these requirements cannot be met, generate error message. */ + +static ffebld +ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, + ffeexprExpr_ r) +{ + ffeinfo linfo, rinfo, ninfo; + ffeinfoBasictype lbt, rbt, nbt; + ffeinfoKindtype lkt, rkt, nkt; + ffeinfoRank lrk, rrk; + ffeinfoKind lkd, rkd; + ffeinfoWhere lwh, rwh, nwh; + + linfo = ffebld_info (ffebld_left (reduced)); + lbt = ffeinfo_basictype (linfo); + lkt = ffeinfo_kindtype (linfo); + lrk = ffeinfo_rank (linfo); + lkd = ffeinfo_kind (linfo); + lwh = ffeinfo_where (linfo); + + rinfo = ffebld_info (ffebld_right (reduced)); + rbt = ffeinfo_basictype (rinfo); + rkt = ffeinfo_kindtype (rinfo); + rrk = ffeinfo_rank (rinfo); + rkd = ffeinfo_kind (rinfo); + rwh = ffeinfo_where (rinfo); + + ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); + + if (((nbt == FFEINFO_basictypeLOGICAL) + || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER))) + && (lrk == 0) && (rrk == 0)) + { + switch (lwh) + { + case FFEINFO_whereCONSTANT: + switch (rwh) + { + case FFEINFO_whereCONSTANT: + nwh = FFEINFO_whereCONSTANT; + break; + + case FFEINFO_whereIMMEDIATE: + nwh = FFEINFO_whereIMMEDIATE; + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + break; + + case FFEINFO_whereIMMEDIATE: + switch (rwh) + { + case FFEINFO_whereCONSTANT: + case FFEINFO_whereIMMEDIATE: + nwh = FFEINFO_whereIMMEDIATE; + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + + ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh, + FFETARGET_charactersizeNONE); + ffebld_set_info (reduced, ninfo); + ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), + l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET)); + ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), + r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET)); + return reduced; + } + + if ((lbt != FFEINFO_basictypeLOGICAL) + && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER))) + { + if ((rbt != FFEINFO_basictypeLOGICAL) + && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER))) + { + if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_BOOL_ARGS_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_finish (); + } + } + else + { + if ((lbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_BOOL_ARG_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_finish (); + } + } + } + else if ((rbt != FFEINFO_basictypeLOGICAL) + && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER))) + { + if ((rbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_BOOL_ARG_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_finish (); + } + } + else if (lrk != 0) + { + if ((lkd != FFEINFO_kindANY) + && ffebad_start (FFEBAD_BOOL_ARG_KIND)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_string ("an array"); + ffebad_finish (); + } + } + else + { + if ((rkd != FFEINFO_kindANY) + && ffebad_start (FFEBAD_BOOL_ARG_KIND)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_string ("an array"); + ffebad_finish (); + } + } + + reduced = ffebld_new_any (); + ffebld_set_info (reduced, ffeinfo_new_any ()); + return reduced; +} + +/* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator + + reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r); + + Makes sure the left and right arguments for reduced have basictype of + CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION. Assign + basictype of CHARACTER and kind of SCALAR to reduced. Calculate effective + size of concatenation and assign that size to reduced. If both left and + right arguments have where of CONSTANT, assign where CONSTANT to reduced, + else assign where FLEETING. + + If these requirements cannot be met, generate error message using the + info in l, op, and r arguments and assign basictype, size, kind, and where + of ANY. */ + +static ffebld +ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, + ffeexprExpr_ r) +{ + ffeinfo linfo, rinfo, ninfo; + ffeinfoBasictype lbt, rbt, nbt; + ffeinfoKindtype lkt, rkt, nkt; + ffeinfoRank lrk, rrk; + ffeinfoKind lkd, rkd, nkd; + ffeinfoWhere lwh, rwh, nwh; + ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk; + + linfo = ffebld_info (ffebld_left (reduced)); + lbt = ffeinfo_basictype (linfo); + lkt = ffeinfo_kindtype (linfo); + lrk = ffeinfo_rank (linfo); + lkd = ffeinfo_kind (linfo); + lwh = ffeinfo_where (linfo); + lszk = ffeinfo_size (linfo); /* Known size. */ + lszm = ffebld_size_max (ffebld_left (reduced)); + + rinfo = ffebld_info (ffebld_right (reduced)); + rbt = ffeinfo_basictype (rinfo); + rkt = ffeinfo_kindtype (rinfo); + rrk = ffeinfo_rank (rinfo); + rkd = ffeinfo_kind (rinfo); + rwh = ffeinfo_where (rinfo); + rszk = ffeinfo_size (rinfo); /* Known size. */ + rszm = ffebld_size_max (ffebld_right (reduced)); + + if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER) + && (lkt == rkt) && (lrk == 0) && (rrk == 0) + && (((lszm != FFETARGET_charactersizeNONE) + && (rszm != FFETARGET_charactersizeNONE)) + || (ffeexpr_context_outer_ (ffeexpr_stack_) + == FFEEXPR_contextLET) + || (ffeexpr_context_outer_ (ffeexpr_stack_) + == FFEEXPR_contextSFUNCDEF))) + { + nbt = FFEINFO_basictypeCHARACTER; + nkd = FFEINFO_kindENTITY; + if ((lszk == FFETARGET_charactersizeNONE) + || (rszk == FFETARGET_charactersizeNONE)) + nszk = FFETARGET_charactersizeNONE; /* Ok only in rhs of LET + stmt. */ + else + nszk = lszk + rszk; + + switch (lwh) + { + case FFEINFO_whereCONSTANT: + switch (rwh) + { + case FFEINFO_whereCONSTANT: + nwh = FFEINFO_whereCONSTANT; + break; + + case FFEINFO_whereIMMEDIATE: + nwh = FFEINFO_whereIMMEDIATE; + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + break; + + case FFEINFO_whereIMMEDIATE: + switch (rwh) + { + case FFEINFO_whereCONSTANT: + case FFEINFO_whereIMMEDIATE: + nwh = FFEINFO_whereIMMEDIATE; + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + + nkt = lkt; + ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk); + ffebld_set_info (reduced, ninfo); + return reduced; + } + + if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER)) + { + if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_finish (); + } + } + else if (lbt != FFEINFO_basictypeCHARACTER) + { + if ((lbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_CONCAT_ARG_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_finish (); + } + } + else if (rbt != FFEINFO_basictypeCHARACTER) + { + if ((rbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_CONCAT_ARG_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_finish (); + } + } + else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE)) + { + if ((lkd != FFEINFO_kindANY) + && ffebad_start (FFEBAD_CONCAT_ARG_KIND)) + { + char *what; + + if (lrk != 0) + what = "an array"; + else + what = "of indeterminate length"; + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_string (what); + ffebad_finish (); + } + } + else + { + if (ffebad_start (FFEBAD_CONCAT_ARG_KIND)) + { + char *what; + + if (rrk != 0) + what = "an array"; + else + what = "of indeterminate length"; + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_string (what); + ffebad_finish (); + } + } + + reduced = ffebld_new_any (); + ffebld_set_info (reduced, ffeinfo_new_any ()); + return reduced; +} + +/* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators + + reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r); + + Makes sure the left and right arguments for reduced have basictype of + INTEGER, REAL, COMPLEX, or CHARACTER. Determine common basictype and + size for reduction. If both left + and right arguments have where of CONSTANT, assign where CONSTANT to + reduced, else assign where FLEETING. Create CONVERT ops for args where + needed. Convert typeless + constants to the desired type/size explicitly. + + If these requirements cannot be met, generate error message. */ + +static ffebld +ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, + ffeexprExpr_ r) +{ + ffeinfo linfo, rinfo, ninfo; + ffeinfoBasictype lbt, rbt, nbt; + ffeinfoKindtype lkt, rkt, nkt; + ffeinfoRank lrk, rrk; + ffeinfoKind lkd, rkd; + ffeinfoWhere lwh, rwh, nwh; + ffetargetCharacterSize lsz, rsz; + + linfo = ffebld_info (ffebld_left (reduced)); + lbt = ffeinfo_basictype (linfo); + lkt = ffeinfo_kindtype (linfo); + lrk = ffeinfo_rank (linfo); + lkd = ffeinfo_kind (linfo); + lwh = ffeinfo_where (linfo); + lsz = ffebld_size_known (ffebld_left (reduced)); + + rinfo = ffebld_info (ffebld_right (reduced)); + rbt = ffeinfo_basictype (rinfo); + rkt = ffeinfo_kindtype (rinfo); + rrk = ffeinfo_rank (rinfo); + rkd = ffeinfo_kind (rinfo); + rwh = ffeinfo_where (rinfo); + rsz = ffebld_size_known (ffebld_right (reduced)); + + ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); + + if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL) + || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER)) + && (lrk == 0) && (rrk == 0)) + { + switch (lwh) + { + case FFEINFO_whereCONSTANT: + switch (rwh) + { + case FFEINFO_whereCONSTANT: + nwh = FFEINFO_whereCONSTANT; + break; + + case FFEINFO_whereIMMEDIATE: + nwh = FFEINFO_whereIMMEDIATE; + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + break; + + case FFEINFO_whereIMMEDIATE: + switch (rwh) + { + case FFEINFO_whereCONSTANT: + case FFEINFO_whereIMMEDIATE: + nwh = FFEINFO_whereIMMEDIATE; + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + + if ((lsz != FFETARGET_charactersizeNONE) + && (rsz != FFETARGET_charactersizeNONE)) + lsz = rsz = (lsz > rsz) ? lsz : rsz; + + ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, + 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE); + ffebld_set_info (reduced, ninfo); + ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), + l->token, op->token, nbt, nkt, 0, lsz, + FFEEXPR_contextLET)); + ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), + r->token, op->token, nbt, nkt, 0, rsz, + FFEEXPR_contextLET)); + return reduced; + } + + if ((lbt == FFEINFO_basictypeLOGICAL) + && (rbt == FFEINFO_basictypeLOGICAL)) + { + if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2", + FFEBAD_severityFATAL)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_finish (); + } + } + else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL) + && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER)) + { + if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) + && (rbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER)) + { + if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_EQOP_ARGS_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_finish (); + } + } + else + { + if ((lbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_EQOP_ARG_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_finish (); + } + } + } + else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) + && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER)) + { + if ((rbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_EQOP_ARG_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_finish (); + } + } + else if (lrk != 0) + { + if ((lkd != FFEINFO_kindANY) + && ffebad_start (FFEBAD_EQOP_ARG_KIND)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_string ("an array"); + ffebad_finish (); + } + } + else + { + if ((rkd != FFEINFO_kindANY) + && ffebad_start (FFEBAD_EQOP_ARG_KIND)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_string ("an array"); + ffebad_finish (); + } + } + + reduced = ffebld_new_any (); + ffebld_set_info (reduced, ffeinfo_new_any ()); + return reduced; +} + +/* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators + + reduced = ffeexpr_reduced_math1_(reduced,op,r); + + Makes sure the argument for reduced has basictype of + INTEGER, REAL, or COMPLEX. If the argument has where of CONSTANT, + assign where CONSTANT to + reduced, else assign where FLEETING. + + If these requirements cannot be met, generate error message. */ + +static ffebld +ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r) +{ + ffeinfo rinfo, ninfo; + ffeinfoBasictype rbt; + ffeinfoKindtype rkt; + ffeinfoRank rrk; + ffeinfoKind rkd; + ffeinfoWhere rwh, nwh; + + rinfo = ffebld_info (ffebld_left (reduced)); + rbt = ffeinfo_basictype (rinfo); + rkt = ffeinfo_kindtype (rinfo); + rrk = ffeinfo_rank (rinfo); + rkd = ffeinfo_kind (rinfo); + rwh = ffeinfo_where (rinfo); + + if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL) + || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0)) + { + switch (rwh) + { + case FFEINFO_whereCONSTANT: + nwh = FFEINFO_whereCONSTANT; + break; + + case FFEINFO_whereIMMEDIATE: + nwh = FFEINFO_whereIMMEDIATE; + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + + ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh, + FFETARGET_charactersizeNONE); + ffebld_set_info (reduced, ninfo); + return reduced; + } + + if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) + && (rbt != FFEINFO_basictypeCOMPLEX)) + { + if ((rbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_MATH_ARG_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_finish (); + } + } + else + { + if ((rkd != FFEINFO_kindANY) + && ffebad_start (FFEBAD_MATH_ARG_KIND)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_string ("an array"); + ffebad_finish (); + } + } + + reduced = ffebld_new_any (); + ffebld_set_info (reduced, ffeinfo_new_any ()); + return reduced; +} + +/* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators + + reduced = ffeexpr_reduced_math2_(reduced,l,op,r); + + Makes sure the left and right arguments for reduced have basictype of + INTEGER, REAL, or COMPLEX. Determine common basictype and + size for reduction (flag expression for combined hollerith/typeless + situations for later determination of effective basictype). If both left + and right arguments have where of CONSTANT, assign where CONSTANT to + reduced, else assign where FLEETING. Create CONVERT ops for args where + needed. Convert typeless + constants to the desired type/size explicitly. + + If these requirements cannot be met, generate error message. */ + +static ffebld +ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, + ffeexprExpr_ r) +{ + ffeinfo linfo, rinfo, ninfo; + ffeinfoBasictype lbt, rbt, nbt; + ffeinfoKindtype lkt, rkt, nkt; + ffeinfoRank lrk, rrk; + ffeinfoKind lkd, rkd; + ffeinfoWhere lwh, rwh, nwh; + + linfo = ffebld_info (ffebld_left (reduced)); + lbt = ffeinfo_basictype (linfo); + lkt = ffeinfo_kindtype (linfo); + lrk = ffeinfo_rank (linfo); + lkd = ffeinfo_kind (linfo); + lwh = ffeinfo_where (linfo); + + rinfo = ffebld_info (ffebld_right (reduced)); + rbt = ffeinfo_basictype (rinfo); + rkt = ffeinfo_kindtype (rinfo); + rrk = ffeinfo_rank (rinfo); + rkd = ffeinfo_kind (rinfo); + rwh = ffeinfo_where (rinfo); + + ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); + + if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL) + || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0)) + { + switch (lwh) + { + case FFEINFO_whereCONSTANT: + switch (rwh) + { + case FFEINFO_whereCONSTANT: + nwh = FFEINFO_whereCONSTANT; + break; + + case FFEINFO_whereIMMEDIATE: + nwh = FFEINFO_whereIMMEDIATE; + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + break; + + case FFEINFO_whereIMMEDIATE: + switch (rwh) + { + case FFEINFO_whereCONSTANT: + case FFEINFO_whereIMMEDIATE: + nwh = FFEINFO_whereIMMEDIATE; + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + + ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh, + FFETARGET_charactersizeNONE); + ffebld_set_info (reduced, ninfo); + ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), + l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET)); + ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), + r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET)); + return reduced; + } + + if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL) + && (lbt != FFEINFO_basictypeCOMPLEX)) + { + if ((rbt != FFEINFO_basictypeINTEGER) + && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX)) + { + if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_MATH_ARGS_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_finish (); + } + } + else + { + if ((lbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_MATH_ARG_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_finish (); + } + } + } + else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) + && (rbt != FFEINFO_basictypeCOMPLEX)) + { + if ((rbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_MATH_ARG_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_finish (); + } + } + else if (lrk != 0) + { + if ((lkd != FFEINFO_kindANY) + && ffebad_start (FFEBAD_MATH_ARG_KIND)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_string ("an array"); + ffebad_finish (); + } + } + else + { + if ((rkd != FFEINFO_kindANY) + && ffebad_start (FFEBAD_MATH_ARG_KIND)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_string ("an array"); + ffebad_finish (); + } + } + + reduced = ffebld_new_any (); + ffebld_set_info (reduced, ffeinfo_new_any ()); + return reduced; +} + +/* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator + + reduced = ffeexpr_reduced_power_(reduced,l,op,r); + + Makes sure the left and right arguments for reduced have basictype of + INTEGER, REAL, or COMPLEX. Determine common basictype and + size for reduction (flag expression for combined hollerith/typeless + situations for later determination of effective basictype). If both left + and right arguments have where of CONSTANT, assign where CONSTANT to + reduced, else assign where FLEETING. Create CONVERT ops for args where + needed. Note that real**int or complex**int + comes out as int = real**int etc with no conversions. + + If these requirements cannot be met, generate error message using the + info in l, op, and r arguments and assign basictype, size, kind, and where + of ANY. */ + +static ffebld +ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, + ffeexprExpr_ r) +{ + ffeinfo linfo, rinfo, ninfo; + ffeinfoBasictype lbt, rbt, nbt; + ffeinfoKindtype lkt, rkt, nkt; + ffeinfoRank lrk, rrk; + ffeinfoKind lkd, rkd; + ffeinfoWhere lwh, rwh, nwh; + + linfo = ffebld_info (ffebld_left (reduced)); + lbt = ffeinfo_basictype (linfo); + lkt = ffeinfo_kindtype (linfo); + lrk = ffeinfo_rank (linfo); + lkd = ffeinfo_kind (linfo); + lwh = ffeinfo_where (linfo); + + rinfo = ffebld_info (ffebld_right (reduced)); + rbt = ffeinfo_basictype (rinfo); + rkt = ffeinfo_kindtype (rinfo); + rrk = ffeinfo_rank (rinfo); + rkd = ffeinfo_kind (rinfo); + rwh = ffeinfo_where (rinfo); + + if ((rbt == FFEINFO_basictypeINTEGER) + && ((lbt == FFEINFO_basictypeREAL) + || (lbt == FFEINFO_basictypeCOMPLEX))) + { + nbt = lbt; + nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT); + if (nkt != FFEINFO_kindtypeREALDEFAULT) + { + nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE); + if (nkt != FFEINFO_kindtypeREALDOUBLE) + nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */ + } + if (rkt == FFEINFO_kindtypeINTEGER4) + { + ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER", + FFEBAD_severityWARNING); + ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_finish (); + } + if (rkt != FFEINFO_kindtypeINTEGERDEFAULT) + { + ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), + r->token, op->token, + FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET)); + rkt = FFEINFO_kindtypeINTEGERDEFAULT; + } + } + else + { + ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); + +#if 0 /* INTEGER4**INTEGER4 works now. */ + if ((nbt == FFEINFO_basictypeINTEGER) + && (nkt != FFEINFO_kindtypeINTEGERDEFAULT)) + nkt = FFEINFO_kindtypeINTEGERDEFAULT; /* Highest kt we can power! */ +#endif + if (((nbt == FFEINFO_basictypeREAL) + || (nbt == FFEINFO_basictypeCOMPLEX)) + && (nkt != FFEINFO_kindtypeREALDEFAULT)) + { + nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE); + if (nkt != FFEINFO_kindtypeREALDOUBLE) + nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */ + } + /* else Gonna turn into an error below. */ + } + + if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL) + || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0)) + { + switch (lwh) + { + case FFEINFO_whereCONSTANT: + switch (rwh) + { + case FFEINFO_whereCONSTANT: + nwh = FFEINFO_whereCONSTANT; + break; + + case FFEINFO_whereIMMEDIATE: + nwh = FFEINFO_whereIMMEDIATE; + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + break; + + case FFEINFO_whereIMMEDIATE: + switch (rwh) + { + case FFEINFO_whereCONSTANT: + case FFEINFO_whereIMMEDIATE: + nwh = FFEINFO_whereIMMEDIATE; + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + + ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh, + FFETARGET_charactersizeNONE); + ffebld_set_info (reduced, ninfo); + ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), + l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET)); + if (rbt != FFEINFO_basictypeINTEGER) + ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), + r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET)); + return reduced; + } + + if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL) + && (lbt != FFEINFO_basictypeCOMPLEX)) + { + if ((rbt != FFEINFO_basictypeINTEGER) + && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX)) + { + if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_MATH_ARGS_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_finish (); + } + } + else + { + if ((lbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_MATH_ARG_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_finish (); + } + } + } + else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) + && (rbt != FFEINFO_basictypeCOMPLEX)) + { + if ((rbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_MATH_ARG_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_finish (); + } + } + else if (lrk != 0) + { + if ((lkd != FFEINFO_kindANY) + && ffebad_start (FFEBAD_MATH_ARG_KIND)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_string ("an array"); + ffebad_finish (); + } + } + else + { + if ((rkd != FFEINFO_kindANY) + && ffebad_start (FFEBAD_MATH_ARG_KIND)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_string ("an array"); + ffebad_finish (); + } + } + + reduced = ffebld_new_any (); + ffebld_set_info (reduced, ffeinfo_new_any ()); + return reduced; +} + +/* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators + + reduced = ffeexpr_reduced_relop2_(reduced,l,op,r); + + Makes sure the left and right arguments for reduced have basictype of + INTEGER, REAL, or CHARACTER. Determine common basictype and + size for reduction. If both left + and right arguments have where of CONSTANT, assign where CONSTANT to + reduced, else assign where FLEETING. Create CONVERT ops for args where + needed. Convert typeless + constants to the desired type/size explicitly. + + If these requirements cannot be met, generate error message. */ + +static ffebld +ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, + ffeexprExpr_ r) +{ + ffeinfo linfo, rinfo, ninfo; + ffeinfoBasictype lbt, rbt, nbt; + ffeinfoKindtype lkt, rkt, nkt; + ffeinfoRank lrk, rrk; + ffeinfoKind lkd, rkd; + ffeinfoWhere lwh, rwh, nwh; + ffetargetCharacterSize lsz, rsz; + + linfo = ffebld_info (ffebld_left (reduced)); + lbt = ffeinfo_basictype (linfo); + lkt = ffeinfo_kindtype (linfo); + lrk = ffeinfo_rank (linfo); + lkd = ffeinfo_kind (linfo); + lwh = ffeinfo_where (linfo); + lsz = ffebld_size_known (ffebld_left (reduced)); + + rinfo = ffebld_info (ffebld_right (reduced)); + rbt = ffeinfo_basictype (rinfo); + rkt = ffeinfo_kindtype (rinfo); + rrk = ffeinfo_rank (rinfo); + rkd = ffeinfo_kind (rinfo); + rwh = ffeinfo_where (rinfo); + rsz = ffebld_size_known (ffebld_right (reduced)); + + ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token); + + if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL) + || (nbt == FFEINFO_basictypeCHARACTER)) + && (lrk == 0) && (rrk == 0)) + { + switch (lwh) + { + case FFEINFO_whereCONSTANT: + switch (rwh) + { + case FFEINFO_whereCONSTANT: + nwh = FFEINFO_whereCONSTANT; + break; + + case FFEINFO_whereIMMEDIATE: + nwh = FFEINFO_whereIMMEDIATE; + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + break; + + case FFEINFO_whereIMMEDIATE: + switch (rwh) + { + case FFEINFO_whereCONSTANT: + case FFEINFO_whereIMMEDIATE: + nwh = FFEINFO_whereIMMEDIATE; + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + break; + + default: + nwh = FFEINFO_whereFLEETING; + break; + } + + if ((lsz != FFETARGET_charactersizeNONE) + && (rsz != FFETARGET_charactersizeNONE)) + lsz = rsz = (lsz > rsz) ? lsz : rsz; + + ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, + 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE); + ffebld_set_info (reduced, ninfo); + ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), + l->token, op->token, nbt, nkt, 0, lsz, + FFEEXPR_contextLET)); + ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), + r->token, op->token, nbt, nkt, 0, rsz, + FFEEXPR_contextLET)); + return reduced; + } + + if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL) + && (lbt != FFEINFO_basictypeCHARACTER)) + { + if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) + && (lbt != FFEINFO_basictypeCHARACTER)) + { + if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_RELOP_ARGS_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_finish (); + } + } + else + { + if ((lbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_RELOP_ARG_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_finish (); + } + } + } + else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL) + && (rbt != FFEINFO_basictypeCHARACTER)) + { + if ((rbt != FFEINFO_basictypeANY) + && ffebad_start (FFEBAD_RELOP_ARG_TYPE)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_finish (); + } + } + else if (lrk != 0) + { + if ((lkd != FFEINFO_kindANY) + && ffebad_start (FFEBAD_RELOP_ARG_KIND)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token)); + ffebad_string ("an array"); + ffebad_finish (); + } + } + else + { + if ((rkd != FFEINFO_kindANY) + && ffebad_start (FFEBAD_RELOP_ARG_KIND)) + { + ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token)); + ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token)); + ffebad_string ("an array"); + ffebad_finish (); + } + } + + reduced = ffebld_new_any (); + ffebld_set_info (reduced, ffeinfo_new_any ()); + return reduced; +} + +/* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL + + reduced = ffeexpr_reduced_ugly1_(reduced,op,r); + + Sigh. */ + +static ffebld +ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r) +{ + ffeinfo rinfo; + ffeinfoBasictype rbt; + ffeinfoKindtype rkt; + ffeinfoRank rrk; + ffeinfoKind rkd; + ffeinfoWhere rwh; + + rinfo = ffebld_info (ffebld_left (reduced)); + rbt = ffeinfo_basictype (rinfo); + rkt = ffeinfo_kindtype (rinfo); + rrk = ffeinfo_rank (rinfo); + rkd = ffeinfo_kind (rinfo); + rwh = ffeinfo_where (rinfo); + + if ((rbt == FFEINFO_basictypeTYPELESS) + || (rbt == FFEINFO_basictypeHOLLERITH)) + { + ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), + r->token, op->token, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET)); + rinfo = ffebld_info (ffebld_left (reduced)); + rbt = FFEINFO_basictypeINTEGER; + rkt = FFEINFO_kindtypeINTEGERDEFAULT; + rrk = 0; + rkd = FFEINFO_kindENTITY; + rwh = ffeinfo_where (rinfo); + } + + if (rbt == FFEINFO_basictypeLOGICAL) + { + ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), + r->token, op->token, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET)); + } + + return reduced; +} + +/* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH + + reduced = ffeexpr_reduced_ugly1log_(reduced,op,r); + + Sigh. */ + +static ffebld +ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r) +{ + ffeinfo rinfo; + ffeinfoBasictype rbt; + ffeinfoKindtype rkt; + ffeinfoRank rrk; + ffeinfoKind rkd; + ffeinfoWhere rwh; + + rinfo = ffebld_info (ffebld_left (reduced)); + rbt = ffeinfo_basictype (rinfo); + rkt = ffeinfo_kindtype (rinfo); + rrk = ffeinfo_rank (rinfo); + rkd = ffeinfo_kind (rinfo); + rwh = ffeinfo_where (rinfo); + + if ((rbt == FFEINFO_basictypeTYPELESS) + || (rbt == FFEINFO_basictypeHOLLERITH)) + { + ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), + r->token, op->token, FFEINFO_basictypeLOGICAL, 0, + FFEINFO_kindtypeLOGICALDEFAULT, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET)); + rinfo = ffebld_info (ffebld_left (reduced)); + rbt = FFEINFO_basictypeLOGICAL; + rkt = FFEINFO_kindtypeLOGICALDEFAULT; + rrk = 0; + rkd = FFEINFO_kindENTITY; + rwh = ffeinfo_where (rinfo); + } + + return reduced; +} + +/* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL + + reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r); + + Sigh. */ + +static ffebld +ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, + ffeexprExpr_ r) +{ + ffeinfo linfo, rinfo; + ffeinfoBasictype lbt, rbt; + ffeinfoKindtype lkt, rkt; + ffeinfoRank lrk, rrk; + ffeinfoKind lkd, rkd; + ffeinfoWhere lwh, rwh; + + linfo = ffebld_info (ffebld_left (reduced)); + lbt = ffeinfo_basictype (linfo); + lkt = ffeinfo_kindtype (linfo); + lrk = ffeinfo_rank (linfo); + lkd = ffeinfo_kind (linfo); + lwh = ffeinfo_where (linfo); + + rinfo = ffebld_info (ffebld_right (reduced)); + rbt = ffeinfo_basictype (rinfo); + rkt = ffeinfo_kindtype (rinfo); + rrk = ffeinfo_rank (rinfo); + rkd = ffeinfo_kind (rinfo); + rwh = ffeinfo_where (rinfo); + + if ((lbt == FFEINFO_basictypeTYPELESS) + || (lbt == FFEINFO_basictypeHOLLERITH)) + { + if ((rbt == FFEINFO_basictypeTYPELESS) + || (rbt == FFEINFO_basictypeHOLLERITH)) + { + ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), + l->token, op->token, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET)); + ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), + r->token, op->token, FFEINFO_basictypeINTEGER, 0, + FFEINFO_kindtypeINTEGERDEFAULT, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET)); + linfo = ffebld_info (ffebld_left (reduced)); + rinfo = ffebld_info (ffebld_right (reduced)); + lbt = rbt = FFEINFO_basictypeINTEGER; + lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT; + lrk = rrk = 0; + lkd = rkd = FFEINFO_kindENTITY; + lwh = ffeinfo_where (linfo); + rwh = ffeinfo_where (rinfo); + } + else + { + ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced), + l->token, ffebld_right (reduced), r->token, + FFEEXPR_contextLET)); + linfo = ffebld_info (ffebld_left (reduced)); + lbt = ffeinfo_basictype (linfo); + lkt = ffeinfo_kindtype (linfo); + lrk = ffeinfo_rank (linfo); + lkd = ffeinfo_kind (linfo); + lwh = ffeinfo_where (linfo); + } + } + else + { + if ((rbt == FFEINFO_basictypeTYPELESS) + || (rbt == FFEINFO_basictypeHOLLERITH)) + { + ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced), + r->token, ffebld_left (reduced), l->token, + FFEEXPR_contextLET)); + rinfo = ffebld_info (ffebld_right (reduced)); + rbt = ffeinfo_basictype (rinfo); + rkt = ffeinfo_kindtype (rinfo); + rrk = ffeinfo_rank (rinfo); + rkd = ffeinfo_kind (rinfo); + rwh = ffeinfo_where (rinfo); + } + /* else Leave it alone. */ + } + + if (lbt == FFEINFO_basictypeLOGICAL) + { + ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), + l->token, op->token, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET)); + } + + if (rbt == FFEINFO_basictypeLOGICAL) + { + ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), + r->token, op->token, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET)); + } + + return reduced; +} + +/* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH + + reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r); + + Sigh. */ + +static ffebld +ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op, + ffeexprExpr_ r) +{ + ffeinfo linfo, rinfo; + ffeinfoBasictype lbt, rbt; + ffeinfoKindtype lkt, rkt; + ffeinfoRank lrk, rrk; + ffeinfoKind lkd, rkd; + ffeinfoWhere lwh, rwh; + + linfo = ffebld_info (ffebld_left (reduced)); + lbt = ffeinfo_basictype (linfo); + lkt = ffeinfo_kindtype (linfo); + lrk = ffeinfo_rank (linfo); + lkd = ffeinfo_kind (linfo); + lwh = ffeinfo_where (linfo); + + rinfo = ffebld_info (ffebld_right (reduced)); + rbt = ffeinfo_basictype (rinfo); + rkt = ffeinfo_kindtype (rinfo); + rrk = ffeinfo_rank (rinfo); + rkd = ffeinfo_kind (rinfo); + rwh = ffeinfo_where (rinfo); + + if ((lbt == FFEINFO_basictypeTYPELESS) + || (lbt == FFEINFO_basictypeHOLLERITH)) + { + if ((rbt == FFEINFO_basictypeTYPELESS) + || (rbt == FFEINFO_basictypeHOLLERITH)) + { + ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced), + l->token, op->token, FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET)); + ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced), + r->token, op->token, FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET)); + linfo = ffebld_info (ffebld_left (reduced)); + rinfo = ffebld_info (ffebld_right (reduced)); + lbt = rbt = FFEINFO_basictypeLOGICAL; + lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT; + lrk = rrk = 0; + lkd = rkd = FFEINFO_kindENTITY; + lwh = ffeinfo_where (linfo); + rwh = ffeinfo_where (rinfo); + } + else + { + ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced), + l->token, ffebld_right (reduced), r->token, + FFEEXPR_contextLET)); + linfo = ffebld_info (ffebld_left (reduced)); + lbt = ffeinfo_basictype (linfo); + lkt = ffeinfo_kindtype (linfo); + lrk = ffeinfo_rank (linfo); + lkd = ffeinfo_kind (linfo); + lwh = ffeinfo_where (linfo); + } + } + else + { + if ((rbt == FFEINFO_basictypeTYPELESS) + || (rbt == FFEINFO_basictypeHOLLERITH)) + { + ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced), + r->token, ffebld_left (reduced), l->token, + FFEEXPR_contextLET)); + rinfo = ffebld_info (ffebld_right (reduced)); + rbt = ffeinfo_basictype (rinfo); + rkt = ffeinfo_kindtype (rinfo); + rrk = ffeinfo_rank (rinfo); + rkd = ffeinfo_kind (rinfo); + rwh = ffeinfo_where (rinfo); + } + /* else Leave it alone. */ + } + + return reduced; +} + +/* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON + is found. + + The idea is to process the tokens as they would be done by normal + expression processing, with the key things being telling the lexer + when hollerith/character constants are about to happen, until the + true closing token is found. */ + +static ffelexHandler +ffeexpr_find_close_paren_ (ffelexToken t, + ffelexHandler after) +{ + ffeexpr_find_.after = after; + ffeexpr_find_.level = 1; + return (ffelexHandler) ffeexpr_nil_rhs_ (t); +} + +static ffelexHandler +ffeexpr_nil_finished_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + if (--ffeexpr_find_.level == 0) + return (ffelexHandler) ffeexpr_find_.after; + return (ffelexHandler) ffeexpr_nil_binary_; + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLON: + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + return (ffelexHandler) ffeexpr_nil_rhs_; + + default: + if (--ffeexpr_find_.level == 0) + return (ffelexHandler) ffeexpr_find_.after (t); + return (ffelexHandler) ffeexpr_nil_rhs_ (t); + } +} + +static ffelexHandler +ffeexpr_nil_rhs_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeQUOTE: + if (ffe_is_vxt ()) + return (ffelexHandler) ffeexpr_nil_quote_; + ffelex_set_expecting_hollerith (-1, '\"', + ffelex_token_where_line (t), + ffelex_token_where_column (t)); + return (ffelexHandler) ffeexpr_nil_apostrophe_; + + case FFELEX_typeAPOSTROPHE: + ffelex_set_expecting_hollerith (-1, '\'', + ffelex_token_where_line (t), + ffelex_token_where_column (t)); + return (ffelexHandler) ffeexpr_nil_apostrophe_; + + case FFELEX_typePERCENT: + return (ffelexHandler) ffeexpr_nil_percent_; + + case FFELEX_typeOPEN_PAREN: + ++ffeexpr_find_.level; + return (ffelexHandler) ffeexpr_nil_rhs_; + + case FFELEX_typePLUS: + case FFELEX_typeMINUS: + return (ffelexHandler) ffeexpr_nil_rhs_; + + case FFELEX_typePERIOD: + return (ffelexHandler) ffeexpr_nil_period_; + + case FFELEX_typeNUMBER: + ffeexpr_hollerith_count_ = atol (ffelex_token_text (t)); + if (ffeexpr_hollerith_count_ > 0) + ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_, + '\0', + ffelex_token_where_line (t), + ffelex_token_where_column (t)); + return (ffelexHandler) ffeexpr_nil_number_; + + case FFELEX_typeNAME: + case FFELEX_typeNAMES: + return (ffelexHandler) ffeexpr_nil_name_rhs_; + + case FFELEX_typeASTERISK: + case FFELEX_typeSLASH: + case FFELEX_typePOWER: + case FFELEX_typeCONCAT: + case FFELEX_typeREL_EQ: + case FFELEX_typeREL_NE: + case FFELEX_typeREL_LE: + case FFELEX_typeREL_GE: + return (ffelexHandler) ffeexpr_nil_rhs_; + + default: + return (ffelexHandler) ffeexpr_nil_finished_ (t); + } +} + +static ffelexHandler +ffeexpr_nil_period_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + case FFELEX_typeNAMES: + ffeexpr_current_dotdot_ = ffeexpr_dotdot_ (t); + switch (ffeexpr_current_dotdot_) + { + case FFEEXPR_dotdotNONE_: + return (ffelexHandler) ffeexpr_nil_rhs_ (t); + + case FFEEXPR_dotdotTRUE_: + case FFEEXPR_dotdotFALSE_: + case FFEEXPR_dotdotNOT_: + return (ffelexHandler) ffeexpr_nil_end_period_; + + default: + return (ffelexHandler) ffeexpr_nil_swallow_period_; + } + break; /* Nothing really reaches here. */ + + case FFELEX_typeNUMBER: + return (ffelexHandler) ffeexpr_nil_real_; + + default: + return (ffelexHandler) ffeexpr_nil_rhs_ (t); + } +} + +static ffelexHandler +ffeexpr_nil_end_period_ (ffelexToken t) +{ + switch (ffeexpr_current_dotdot_) + { + case FFEEXPR_dotdotNOT_: + if (ffelex_token_type (t) != FFELEX_typePERIOD) + return (ffelexHandler) ffeexpr_nil_rhs_ (t); + return (ffelexHandler) ffeexpr_nil_rhs_; + + case FFEEXPR_dotdotTRUE_: + case FFEEXPR_dotdotFALSE_: + if (ffelex_token_type (t) != FFELEX_typePERIOD) + return (ffelexHandler) ffeexpr_nil_binary_ (t); + return (ffelexHandler) ffeexpr_nil_binary_; + + default: + assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL); + exit (0); + return NULL; + } +} + +static ffelexHandler +ffeexpr_nil_swallow_period_ (ffelexToken t) +{ + if (ffelex_token_type (t) != FFELEX_typePERIOD) + return (ffelexHandler) ffeexpr_nil_rhs_ (t); + return (ffelexHandler) ffeexpr_nil_rhs_; +} + +static ffelexHandler +ffeexpr_nil_real_ (ffelexToken t) +{ + char d; + char *p; + + if (((ffelex_token_type (t) != FFELEX_typeNAME) + && (ffelex_token_type (t) != FFELEX_typeNAMES)) + || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), + 'D', 'd') + || ffesrc_char_match_init (d, 'E', 'e') + || ffesrc_char_match_init (d, 'Q', 'q'))) + && ffeexpr_isdigits_ (++p))) + return (ffelexHandler) ffeexpr_nil_binary_ (t); + + if (*p == '\0') + return (ffelexHandler) ffeexpr_nil_real_exponent_; + return (ffelexHandler) ffeexpr_nil_binary_; +} + +static ffelexHandler +ffeexpr_nil_real_exponent_ (ffelexToken t) +{ + if ((ffelex_token_type (t) != FFELEX_typePLUS) + && (ffelex_token_type (t) != FFELEX_typeMINUS)) + return (ffelexHandler) ffeexpr_nil_binary_ (t); + + return (ffelexHandler) ffeexpr_nil_real_exp_sign_; +} + +static ffelexHandler +ffeexpr_nil_real_exp_sign_ (ffelexToken t) +{ + if (ffelex_token_type (t) != FFELEX_typeNUMBER) + return (ffelexHandler) ffeexpr_nil_binary_ (t); + return (ffelexHandler) ffeexpr_nil_binary_; +} + +static ffelexHandler +ffeexpr_nil_number_ (ffelexToken t) +{ + char d; + char *p; + + if (ffeexpr_hollerith_count_ > 0) + ffelex_set_expecting_hollerith (0, '\0', + ffewhere_line_unknown (), + ffewhere_column_unknown ()); + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + case FFELEX_typeNAMES: + if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), + 'D', 'd') + || ffesrc_char_match_init (d, 'E', 'e') + || ffesrc_char_match_init (d, 'Q', 'q')) + && ffeexpr_isdigits_ (++p)) + { + if (*p == '\0') + { + ffeexpr_find_.t = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_nil_number_exponent_; + } + return (ffelexHandler) ffeexpr_nil_binary_; + } + break; + + case FFELEX_typePERIOD: + ffeexpr_find_.t = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_nil_number_period_; + + case FFELEX_typeHOLLERITH: + return (ffelexHandler) ffeexpr_nil_binary_; + + default: + break; + } + return (ffelexHandler) ffeexpr_nil_binary_ (t); +} + +/* Expects ffeexpr_find_.t. */ + +static ffelexHandler +ffeexpr_nil_number_exponent_ (ffelexToken t) +{ + ffelexHandler nexthandler; + + if ((ffelex_token_type (t) != FFELEX_typePLUS) + && (ffelex_token_type (t) != FFELEX_typeMINUS)) + { + nexthandler + = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t); + ffelex_token_kill (ffeexpr_find_.t); + return (ffelexHandler) (*nexthandler) (t); + } + + ffelex_token_kill (ffeexpr_find_.t); + return (ffelexHandler) ffeexpr_nil_number_exp_sign_; +} + +static ffelexHandler +ffeexpr_nil_number_exp_sign_ (ffelexToken t) +{ + if (ffelex_token_type (t) != FFELEX_typeNUMBER) + return (ffelexHandler) ffeexpr_nil_binary_ (t); + + return (ffelexHandler) ffeexpr_nil_binary_; +} + +/* Expects ffeexpr_find_.t. */ + +static ffelexHandler +ffeexpr_nil_number_period_ (ffelexToken t) +{ + ffelexHandler nexthandler; + char d; + char *p; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + case FFELEX_typeNAMES: + if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), + 'D', 'd') + || ffesrc_char_match_init (d, 'E', 'e') + || ffesrc_char_match_init (d, 'Q', 'q')) + && ffeexpr_isdigits_ (++p)) + { + if (*p == '\0') + return (ffelexHandler) ffeexpr_nil_number_per_exp_; + ffelex_token_kill (ffeexpr_find_.t); + return (ffelexHandler) ffeexpr_nil_binary_; + } + nexthandler + = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t); + ffelex_token_kill (ffeexpr_find_.t); + return (ffelexHandler) (*nexthandler) (t); + + case FFELEX_typeNUMBER: + ffelex_token_kill (ffeexpr_find_.t); + return (ffelexHandler) ffeexpr_nil_number_real_; + + default: + break; + } + ffelex_token_kill (ffeexpr_find_.t); + return (ffelexHandler) ffeexpr_nil_binary_ (t); +} + +/* Expects ffeexpr_find_.t. */ + +static ffelexHandler +ffeexpr_nil_number_per_exp_ (ffelexToken t) +{ + if ((ffelex_token_type (t) != FFELEX_typePLUS) + && (ffelex_token_type (t) != FFELEX_typeMINUS)) + { + ffelexHandler nexthandler; + + nexthandler + = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t); + ffelex_token_kill (ffeexpr_find_.t); + return (ffelexHandler) (*nexthandler) (t); + } + + ffelex_token_kill (ffeexpr_find_.t); + return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_; +} + +static ffelexHandler +ffeexpr_nil_number_real_ (ffelexToken t) +{ + char d; + char *p; + + if (((ffelex_token_type (t) != FFELEX_typeNAME) + && (ffelex_token_type (t) != FFELEX_typeNAMES)) + || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), + 'D', 'd') + || ffesrc_char_match_init (d, 'E', 'e') + || ffesrc_char_match_init (d, 'Q', 'q'))) + && ffeexpr_isdigits_ (++p))) + return (ffelexHandler) ffeexpr_nil_binary_ (t); + + if (*p == '\0') + return (ffelexHandler) ffeexpr_nil_number_real_exp_; + + return (ffelexHandler) ffeexpr_nil_binary_; +} + +static ffelexHandler +ffeexpr_nil_num_per_exp_sign_ (ffelexToken t) +{ + if (ffelex_token_type (t) != FFELEX_typeNUMBER) + return (ffelexHandler) ffeexpr_nil_binary_ (t); + return (ffelexHandler) ffeexpr_nil_binary_; +} + +static ffelexHandler +ffeexpr_nil_number_real_exp_ (ffelexToken t) +{ + if ((ffelex_token_type (t) != FFELEX_typePLUS) + && (ffelex_token_type (t) != FFELEX_typeMINUS)) + return (ffelexHandler) ffeexpr_nil_binary_ (t); + return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_; +} + +static ffelexHandler +ffeexpr_nil_num_real_exp_sn_ (ffelexToken t) +{ + if (ffelex_token_type (t) != FFELEX_typeNUMBER) + return (ffelexHandler) ffeexpr_nil_binary_ (t); + return (ffelexHandler) ffeexpr_nil_binary_; +} + +static ffelexHandler +ffeexpr_nil_binary_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typePLUS: + case FFELEX_typeMINUS: + case FFELEX_typeASTERISK: + case FFELEX_typeSLASH: + case FFELEX_typePOWER: + case FFELEX_typeCONCAT: + case FFELEX_typeOPEN_ANGLE: + case FFELEX_typeCLOSE_ANGLE: + case FFELEX_typeREL_EQ: + case FFELEX_typeREL_NE: + case FFELEX_typeREL_GE: + case FFELEX_typeREL_LE: + return (ffelexHandler) ffeexpr_nil_rhs_; + + case FFELEX_typePERIOD: + return (ffelexHandler) ffeexpr_nil_binary_period_; + + default: + return (ffelexHandler) ffeexpr_nil_finished_ (t); + } +} + +static ffelexHandler +ffeexpr_nil_binary_period_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + case FFELEX_typeNAMES: + ffeexpr_current_dotdot_ = ffeexpr_dotdot_ (t); + switch (ffeexpr_current_dotdot_) + { + case FFEEXPR_dotdotTRUE_: + case FFEEXPR_dotdotFALSE_: + case FFEEXPR_dotdotNOT_: + return (ffelexHandler) ffeexpr_nil_binary_sw_per_; + + default: + return (ffelexHandler) ffeexpr_nil_binary_end_per_; + } + break; /* Nothing really reaches here. */ + + default: + return (ffelexHandler) ffeexpr_nil_binary_ (t); + } +} + +static ffelexHandler +ffeexpr_nil_binary_end_per_ (ffelexToken t) +{ + if (ffelex_token_type (t) != FFELEX_typePERIOD) + return (ffelexHandler) ffeexpr_nil_rhs_ (t); + return (ffelexHandler) ffeexpr_nil_rhs_; +} + +static ffelexHandler +ffeexpr_nil_binary_sw_per_ (ffelexToken t) +{ + if (ffelex_token_type (t) != FFELEX_typePERIOD) + return (ffelexHandler) ffeexpr_nil_binary_ (t); + return (ffelexHandler) ffeexpr_nil_binary_; +} + +static ffelexHandler +ffeexpr_nil_quote_ (ffelexToken t) +{ + if (ffelex_token_type (t) != FFELEX_typeNUMBER) + return (ffelexHandler) ffeexpr_nil_rhs_ (t); + return (ffelexHandler) ffeexpr_nil_binary_; +} + +static ffelexHandler +ffeexpr_nil_apostrophe_ (ffelexToken t) +{ + assert (ffelex_token_type (t) == FFELEX_typeCHARACTER); + return (ffelexHandler) ffeexpr_nil_apos_char_; +} + +static ffelexHandler +ffeexpr_nil_apos_char_ (ffelexToken t) +{ + char c; + + if ((ffelex_token_type (t) == FFELEX_typeNAME) + || (ffelex_token_type (t) == FFELEX_typeNAMES)) + { + if ((ffelex_token_length (t) == 1) + && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), + 'B', 'b') + || ffesrc_char_match_init (c, 'O', 'o') + || ffesrc_char_match_init (c, 'X', 'x') + || ffesrc_char_match_init (c, 'Z', 'z'))) + return (ffelexHandler) ffeexpr_nil_binary_; + } + if ((ffelex_token_type (t) == FFELEX_typeNAME) + || (ffelex_token_type (t) == FFELEX_typeNAMES)) + return (ffelexHandler) ffeexpr_nil_rhs_ (t); + return (ffelexHandler) ffeexpr_nil_substrp_ (t); +} + +static ffelexHandler +ffeexpr_nil_name_rhs_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeQUOTE: + case FFELEX_typeAPOSTROPHE: + ffelex_set_hexnum (TRUE); + return (ffelexHandler) ffeexpr_nil_name_apos_; + + case FFELEX_typeOPEN_PAREN: + ++ffeexpr_find_.level; + return (ffelexHandler) ffeexpr_nil_rhs_; + + default: + return (ffelexHandler) ffeexpr_nil_binary_ (t); + } +} + +static ffelexHandler +ffeexpr_nil_name_apos_ (ffelexToken t) +{ + if (ffelex_token_type (t) == FFELEX_typeNAME) + return (ffelexHandler) ffeexpr_nil_name_apos_name_; + return (ffelexHandler) ffeexpr_nil_binary_ (t); +} + +static ffelexHandler +ffeexpr_nil_name_apos_name_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeAPOSTROPHE: + case FFELEX_typeQUOTE: + return (ffelexHandler) ffeexpr_nil_finished_; + + default: + return (ffelexHandler) ffeexpr_nil_finished_ (t); + } +} + +static ffelexHandler +ffeexpr_nil_percent_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + case FFELEX_typeNAMES: + ffeexpr_stack_->percent = ffeexpr_percent_ (t); + ffeexpr_find_.t = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_nil_percent_name_; + + default: + return (ffelexHandler) ffeexpr_nil_rhs_ (t); + } +} + +/* Expects ffeexpr_find_.t. */ + +static ffelexHandler +ffeexpr_nil_percent_name_ (ffelexToken t) +{ + ffelexHandler nexthandler; + + if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN) + { + nexthandler + = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t); + ffelex_token_kill (ffeexpr_find_.t); + return (ffelexHandler) (*nexthandler) (t); + } + + ffelex_token_kill (ffeexpr_find_.t); + ++ffeexpr_find_.level; + return (ffelexHandler) ffeexpr_nil_rhs_; +} + +static ffelexHandler +ffeexpr_nil_substrp_ (ffelexToken t) +{ + if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN) + return (ffelexHandler) ffeexpr_nil_binary_ (t); + + ++ffeexpr_find_.level; + return (ffelexHandler) ffeexpr_nil_rhs_; +} + +/* ffeexpr_finished_ -- Reduce expression stack to one expr, finish + + ffelexToken t; + return ffeexpr_finished_(t); + + Reduces expression stack to one (or zero) elements by repeatedly reducing + the top operator on the stack (or, if the top element on the stack is + itself an operator, issuing an error message and discarding it). Calls + finishing routine with the expression, returning the ffelexHandler it + returns to the caller. */ + +static ffelexHandler +ffeexpr_finished_ (ffelexToken t) +{ + ffeexprExpr_ operand; /* This is B in -B or A+B. */ + ffebld expr; + ffeexprCallback callback; + ffeexprStack_ s; + ffebldConstant constnode; /* For detecting magical number. */ + ffelexToken ft; /* Temporary copy of first token in + expression. */ + ffelexHandler next; + ffeinfo info; + bool error = FALSE; + + while (((operand = ffeexpr_stack_->exprstack) != NULL) + && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_))) + { + if (operand->type == FFEEXPR_exprtypeOPERAND_) + ffeexpr_reduce_ (); + else + { + if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR)) + { + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token), + ffelex_token_where_column (ffeexpr_stack_->exprstack->token)); + ffebad_finish (); + } + ffeexpr_stack_->exprstack = operand->previous; /* Pop the useless + operator. */ + ffeexpr_expr_kill_ (operand); + } + } + + assert ((operand == NULL) || (operand->previous == NULL)); + + ffebld_pool_pop (); + if (operand == NULL) + expr = NULL; + else + { + expr = operand->u.operand; + info = ffebld_info (expr); + if ((ffebld_op (expr) == FFEBLD_opCONTER) + && (ffebld_conter_orig (expr) == NULL) + && ffebld_constant_is_magical (constnode = ffebld_conter (expr))) + { + ffetarget_integer_bad_magical (operand->token); + } + ffeexpr_expr_kill_ (operand); + ffeexpr_stack_->exprstack = NULL; + } + + ft = ffeexpr_stack_->first_token; + +again: /* :::::::::::::::::::: */ + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextLET: + case FFEEXPR_contextSFUNCDEF: + error = (expr == NULL) + || (ffeinfo_rank (info) != 0); + break; + + case FFEEXPR_contextPAREN_: + if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) + break; + switch (ffeinfo_basictype (info)) + { + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + default: + break; + } + break; + + case FFEEXPR_contextPARENFILENUM_: + if (ffelex_token_type (t) != FFELEX_typeCOMMA) + ffeexpr_stack_->context = FFEEXPR_contextPAREN_; + else + ffeexpr_stack_->context = FFEEXPR_contextFILENUM; + goto again; /* :::::::::::::::::::: */ + + case FFEEXPR_contextPARENFILEUNIT_: + if (ffelex_token_type (t) != FFELEX_typeCOMMA) + ffeexpr_stack_->context = FFEEXPR_contextPAREN_; + else + ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT; + goto again; /* :::::::::::::::::::: */ + + case FFEEXPR_contextACTUALARGEXPR_: + case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: + switch ((expr == NULL) ? FFEINFO_basictypeNONE + : ffeinfo_basictype (info)) + { + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + if (!ffe_is_ugly_args () + && ffebad_start (FFEBAD_ACTUALARG)) + { + ffebad_here (0, ffelex_token_where_line (ft), + ffelex_token_where_column (ft)); + ffebad_finish (); + } + break; + + default: + break; + } + error = ((expr == NULL) && ffe_is_pedantic ()) + || ((expr != NULL) && (ffeinfo_rank (info) != 0)); + break; + + case FFEEXPR_contextACTUALARG_: + case FFEEXPR_contextSFUNCDEFACTUALARG_: + switch ((expr == NULL) ? FFEINFO_basictypeNONE + : ffeinfo_basictype (info)) + { + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: +#if 0 /* Should never get here. */ + expr = ffeexpr_convert (expr, ft, ft, + FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, + 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); +#else + assert ("why hollerith/typeless in actualarg_?" == NULL); +#endif + break; + + default: + break; + } + switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr)) + { + case FFEBLD_opSYMTER: + case FFEBLD_opPERCENT_LOC: + case FFEBLD_opPERCENT_VAL: + case FFEBLD_opPERCENT_REF: + case FFEBLD_opPERCENT_DESCR: + error = FALSE; + break; + + default: + error = (expr != NULL) && (ffeinfo_rank (info) != 0); + break; + } + { + ffesymbol s; + ffeinfoWhere where; + ffeinfoKind kind; + + if (!error + && (expr != NULL) + && (ffebld_op (expr) == FFEBLD_opSYMTER) + && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)), + (where == FFEINFO_whereINTRINSIC) + || (where == FFEINFO_whereGLOBAL) + || ((where == FFEINFO_whereDUMMY) + && ((kind = ffesymbol_kind (s)), + (kind == FFEINFO_kindFUNCTION) + || (kind == FFEINFO_kindSUBROUTINE)))) + && !ffesymbol_explicitwhere (s)) + { + ffebad_start (where == FFEINFO_whereINTRINSIC + ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL); + ffebad_here (0, ffelex_token_where_line (ft), + ffelex_token_where_column (ft)); + ffebad_string (ffesymbol_text (s)); + ffebad_finish (); + ffesymbol_signal_change (s); + ffesymbol_set_explicitwhere (s, TRUE); + ffesymbol_signal_unreported (s); + } + } + break; + + case FFEEXPR_contextINDEX_: + case FFEEXPR_contextSFUNCDEFINDEX_: + case FFEEXPR_contextRETURN: + if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) + break; + switch ((expr == NULL) ? FFEINFO_basictypeNONE + : ffeinfo_basictype (info)) + { + case FFEINFO_basictypeNONE: + error = FALSE; + break; + + case FFEINFO_basictypeLOGICAL: + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + /* Fall through. */ + case FFEINFO_basictypeREAL: + case FFEINFO_basictypeCOMPLEX: + if (ffe_is_pedantic ()) + { + error = TRUE; + break; + } + /* Fall through. */ + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + error = FALSE; + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + default: + error = TRUE; + break; + } + break; /* expr==NULL ok for substring; element case + caught by callback. */ + + case FFEEXPR_contextDO: + if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) + break; + switch (ffeinfo_basictype (info)) + { + case FFEINFO_basictypeLOGICAL: + error = !ffe_is_ugly_logint (); + if (!ffeexpr_stack_->is_rhs) + break; /* Don't convert lhs variable. */ + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + ffeinfo_kindtype (ffebld_info (expr)), 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + if (!ffeexpr_stack_->is_rhs) + { + error = TRUE; + break; /* Don't convert lhs variable. */ + } + break; + + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeREAL: + break; + + default: + error = TRUE; + break; + } + if (!ffeexpr_stack_->is_rhs + && (ffebld_op (expr) != FFEBLD_opSYMTER)) + error = TRUE; + break; + + case FFEEXPR_contextDOWHILE: + case FFEEXPR_contextIF: + if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) + break; + switch (ffeinfo_basictype (info)) + { + case FFEINFO_basictypeINTEGER: + error = FALSE; + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + /* Fall through. */ + case FFEINFO_basictypeLOGICAL: + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + error = FALSE; + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + default: + error = TRUE; + break; + } + break; + + case FFEEXPR_contextASSIGN: + case FFEEXPR_contextAGOTO: + switch ((expr == NULL) ? FFEINFO_basictypeNONE + : ffeinfo_basictype (info)) + { + case FFEINFO_basictypeINTEGER: + error = (ffeinfo_kindtype (info) != ffecom_label_kind ()); + break; + + case FFEINFO_basictypeLOGICAL: + error = !ffe_is_ugly_logint () + || (ffeinfo_kindtype (info) != ffecom_label_kind ()); + break; + + default: + error = TRUE; + break; + } + if ((expr == NULL) || (ffeinfo_rank (info) != 0) + || (ffebld_op (expr) != FFEBLD_opSYMTER)) + error = TRUE; + break; + + case FFEEXPR_contextCGOTO: + case FFEEXPR_contextFORMAT: + case FFEEXPR_contextDIMLIST: + case FFEEXPR_contextFILENUM: /* See equiv code in _ambig_. */ + if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) + break; + switch (ffeinfo_basictype (info)) + { + case FFEINFO_basictypeLOGICAL: + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + /* Fall through. */ + case FFEINFO_basictypeREAL: + case FFEINFO_basictypeCOMPLEX: + if (ffe_is_pedantic ()) + { + error = TRUE; + break; + } + /* Fall through. */ + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + error = FALSE; + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + default: + error = TRUE; + break; + } + break; + + case FFEEXPR_contextARITHIF: + if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) + break; + switch (ffeinfo_basictype (info)) + { + case FFEINFO_basictypeLOGICAL: + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + if (ffe_is_pedantic ()) + { + error = TRUE; + break; + } + /* Fall through. */ + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + /* Fall through. */ + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeREAL: + error = FALSE; + break; + + default: + error = TRUE; + break; + } + break; + + case FFEEXPR_contextSTOP: + if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) + break; + switch ((expr == NULL) ? FFEINFO_basictypeNONE + : ffeinfo_basictype (info)) + { + case FFEINFO_basictypeINTEGER: + error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT); + break; + + case FFEINFO_basictypeCHARACTER: + error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT); + break; + + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + error = FALSE; + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + case FFEINFO_basictypeNONE: + error = FALSE; + break; + + default: + error = TRUE; + break; + } + if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER) + || (ffebld_conter_orig (expr) != NULL))) + error = TRUE; + break; + + case FFEEXPR_contextINCLUDE: + error = (expr == NULL) || (ffeinfo_rank (info) != 0) + || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER) + || (ffebld_op (expr) != FFEBLD_opCONTER) + || (ffebld_conter_orig (expr) != NULL); + break; + + case FFEEXPR_contextSELECTCASE: + if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) + break; + switch (ffeinfo_basictype (info)) + { + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeCHARACTER: + case FFEINFO_basictypeLOGICAL: + error = FALSE; + break; + + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + error = FALSE; + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + default: + error = TRUE; + break; + } + break; + + case FFEEXPR_contextCASE: + if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) + break; + switch ((expr == NULL) ? FFEINFO_basictypeINTEGER + : ffeinfo_basictype (info)) + { + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeCHARACTER: + case FFEINFO_basictypeLOGICAL: + error = FALSE; + break; + + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + error = FALSE; + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + default: + error = TRUE; + break; + } + if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER)) + error = TRUE; + break; + + case FFEEXPR_contextCHARACTERSIZE: + case FFEEXPR_contextKINDTYPE: + case FFEEXPR_contextDIMLISTCOMMON: + if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) + break; + switch ((expr == NULL) ? FFEINFO_basictypeNONE + : ffeinfo_basictype (info)) + { + case FFEINFO_basictypeLOGICAL: + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + /* Fall through. */ + case FFEINFO_basictypeREAL: + case FFEINFO_basictypeCOMPLEX: + if (ffe_is_pedantic ()) + { + error = TRUE; + break; + } + /* Fall through. */ + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + error = FALSE; + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + default: + error = TRUE; + break; + } + if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER)) + error = TRUE; + break; + + case FFEEXPR_contextEQVINDEX_: + if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0))) + break; + switch ((expr == NULL) ? FFEINFO_basictypeNONE + : ffeinfo_basictype (info)) + { + case FFEINFO_basictypeNONE: + error = FALSE; + break; + + case FFEINFO_basictypeLOGICAL: + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + /* Fall through. */ + case FFEINFO_basictypeREAL: + case FFEINFO_basictypeCOMPLEX: + if (ffe_is_pedantic ()) + { + error = TRUE; + break; + } + /* Fall through. */ + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + error = FALSE; + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + default: + error = TRUE; + break; + } + if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER)) + error = TRUE; + break; + + case FFEEXPR_contextPARAMETER: + if (ffeexpr_stack_->is_rhs) + error = (expr == NULL) || (ffeinfo_rank (info) != 0) + || (ffebld_op (expr) != FFEBLD_opCONTER); + else + error = (expr == NULL) || (ffeinfo_rank (info) != 0) + || (ffebld_op (expr) != FFEBLD_opSYMTER); + break; + + case FFEEXPR_contextINDEXORACTUALARG_: + if (ffelex_token_type (t) == FFELEX_typeCOLON) + ffeexpr_stack_->context = FFEEXPR_contextINDEX_; + else + ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_; + goto again; /* :::::::::::::::::::: */ + + case FFEEXPR_contextINDEXORACTUALARGEXPR_: + if (ffelex_token_type (t) == FFELEX_typeCOLON) + ffeexpr_stack_->context = FFEEXPR_contextINDEX_; + else + ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; + goto again; /* :::::::::::::::::::: */ + + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + if (ffelex_token_type (t) == FFELEX_typeCOLON) + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_; + else + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_; + goto again; /* :::::::::::::::::::: */ + + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: + if (ffelex_token_type (t) == FFELEX_typeCOLON) + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_; + else + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; + goto again; /* :::::::::::::::::::: */ + + case FFEEXPR_contextIMPDOCTRL_: + if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) + break; + if (!ffeexpr_stack_->is_rhs + && (ffebld_op (expr) != FFEBLD_opSYMTER)) + error = TRUE; + switch (ffeinfo_basictype (info)) + { + case FFEINFO_basictypeLOGICAL: + error = error && !ffe_is_ugly_logint (); + if (!ffeexpr_stack_->is_rhs) + break; /* Don't convert lhs variable. */ + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + ffeinfo_kindtype (ffebld_info (expr)), 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + break; + + case FFEINFO_basictypeREAL: + if (!ffeexpr_stack_->is_rhs + && ffe_is_warn_surprising () + && !error) + { + ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */ + ffebad_here (0, ffelex_token_where_line (ft), + ffelex_token_where_column (ft)); + ffebad_string (ffelex_token_text (ft)); + ffebad_finish (); + } + break; + + default: + error = TRUE; + break; + } + break; + + case FFEEXPR_contextDATAIMPDOCTRL_: + if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) + break; + if (ffeexpr_stack_->is_rhs) + { + if ((ffebld_op (expr) != FFEBLD_opCONTER) + && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE)) + error = TRUE; + } + else if ((ffebld_op (expr) != FFEBLD_opSYMTER) + || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE)) + error = TRUE; + switch (ffeinfo_basictype (info)) + { + case FFEINFO_basictypeLOGICAL: + error = error + && (ffeinfo_kindtype (info) != FFEINFO_kindtypeLOGICALDEFAULT); + if (!ffeexpr_stack_->is_rhs) + break; /* Don't convert lhs variable. */ + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + case FFEINFO_basictypeINTEGER: + error = error && + (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT); + break; + + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + case FFEINFO_basictypeREAL: + if (!ffeexpr_stack_->is_rhs + && ffe_is_warn_surprising () + && !error) + { + ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */ + ffebad_here (0, ffelex_token_where_line (ft), + ffelex_token_where_column (ft)); + ffebad_string (ffelex_token_text (ft)); + ffebad_finish (); + } + break; + + default: + error = TRUE; + break; + } + break; + + case FFEEXPR_contextIMPDOITEM_: + if (ffelex_token_type (t) == FFELEX_typeEQUALS) + { + ffeexpr_stack_->is_rhs = FALSE; + ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_; + goto again; /* :::::::::::::::::::: */ + } + /* Fall through. */ + case FFEEXPR_contextIOLIST: + case FFEEXPR_contextFILEVXTCODE: + switch ((expr == NULL) ? FFEINFO_basictypeNONE + : ffeinfo_basictype (info)) + { + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + default: + break; + } + error = (expr == NULL) + || ((ffeinfo_rank (info) != 0) + && ((ffebld_op (expr) != FFEBLD_opSYMTER) + || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL) + || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr))) + == FFEBLD_opSTAR))); /* Bad if null expr, or if + array that is not a SYMTER + (can't happen yet, I + think) or has a NULL or + STAR (assumed) array + size. */ + break; + + case FFEEXPR_contextIMPDOITEMDF_: + if (ffelex_token_type (t) == FFELEX_typeEQUALS) + { + ffeexpr_stack_->is_rhs = FALSE; + ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_; + goto again; /* :::::::::::::::::::: */ + } + /* Fall through. */ + case FFEEXPR_contextIOLISTDF: + switch ((expr == NULL) ? FFEINFO_basictypeNONE + : ffeinfo_basictype (info)) + { + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + default: + break; + } + error + = (expr == NULL) + || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER) + && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)) + || ((ffeinfo_rank (info) != 0) + && ((ffebld_op (expr) != FFEBLD_opSYMTER) + || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL) + || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr))) + == FFEBLD_opSTAR))); /* Bad if null expr, + non-default-kindtype + character expr, or if + array that is not a SYMTER + (can't happen yet, I + think) or has a NULL or + STAR (assumed) array + size. */ + break; + + case FFEEXPR_contextDATAIMPDOITEM_: + error = (expr == NULL) + || (ffebld_op (expr) != FFEBLD_opARRAYREF) + || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR) + && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR)); + break; + + case FFEEXPR_contextDATAIMPDOINDEX_: + if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) + break; + switch (ffeinfo_basictype (info)) + { + case FFEINFO_basictypeLOGICAL: + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + /* Fall through. */ + case FFEINFO_basictypeREAL: + case FFEINFO_basictypeCOMPLEX: + if (ffe_is_pedantic ()) + { + error = TRUE; + break; + } + /* Fall through. */ + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + error = FALSE; + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + default: + error = TRUE; + break; + } + if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT) + && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE)) + error = TRUE; + break; + + case FFEEXPR_contextDATA: + if (expr == NULL) + error = TRUE; + else if (ffeexpr_stack_->is_rhs) + error = (ffebld_op (expr) != FFEBLD_opCONTER); + else if (ffebld_op (expr) == FFEBLD_opSYMTER) + error = FALSE; + else + error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR); + break; + + case FFEEXPR_contextINITVAL: + error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER); + break; + + case FFEEXPR_contextEQUIVALENCE: + if (expr == NULL) + error = TRUE; + else if (ffebld_op (expr) == FFEBLD_opSYMTER) + error = FALSE; + else + error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR); + break; + + case FFEEXPR_contextFILEASSOC: + case FFEEXPR_contextFILEINT: + switch ((expr == NULL) ? FFEINFO_basictypeNONE + : ffeinfo_basictype (info)) + { + case FFEINFO_basictypeINTEGER: + error = FALSE; + break; + + default: + error = TRUE; + break; + } + if ((expr == NULL) || (ffeinfo_rank (info) != 0)) + error = TRUE; + break; + + case FFEEXPR_contextFILEDFINT: + switch ((expr == NULL) ? FFEINFO_basictypeNONE + : ffeinfo_basictype (info)) + { + case FFEINFO_basictypeINTEGER: + error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT); + break; + + default: + error = TRUE; + break; + } + if ((expr == NULL) || (ffeinfo_rank (info) != 0)) + error = TRUE; + break; + + case FFEEXPR_contextFILELOG: + switch ((expr == NULL) ? FFEINFO_basictypeNONE + : ffeinfo_basictype (info)) + { + case FFEINFO_basictypeLOGICAL: + error = FALSE; + break; + + default: + error = TRUE; + break; + } + if ((expr == NULL) || (ffeinfo_rank (info) != 0)) + error = TRUE; + break; + + case FFEEXPR_contextFILECHAR: + switch ((expr == NULL) ? FFEINFO_basictypeNONE + : ffeinfo_basictype (info)) + { + case FFEINFO_basictypeCHARACTER: + error = FALSE; + break; + + default: + error = TRUE; + break; + } + if ((expr == NULL) || (ffeinfo_rank (info) != 0)) + error = TRUE; + break; + + case FFEEXPR_contextFILENUMCHAR: + if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) + break; + switch (ffeinfo_basictype (info)) + { + case FFEINFO_basictypeLOGICAL: + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + /* Fall through. */ + case FFEINFO_basictypeREAL: + case FFEINFO_basictypeCOMPLEX: + if (ffe_is_pedantic ()) + { + error = TRUE; + break; + } + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeCHARACTER: + error = FALSE; + break; + + default: + error = TRUE; + break; + } + break; + + case FFEEXPR_contextFILEDFCHAR: + if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0))) + break; + switch (ffeinfo_basictype (info)) + { + case FFEINFO_basictypeCHARACTER: + error + = (ffeinfo_kindtype (info) + != FFEINFO_kindtypeCHARACTERDEFAULT); + break; + + default: + error = TRUE; + break; + } + if (!ffeexpr_stack_->is_rhs + && (ffebld_op (expr) == FFEBLD_opSUBSTR)) + error = TRUE; + break; + + case FFEEXPR_contextFILEUNIT: /* See equiv code in _ambig_. */ + switch ((expr == NULL) ? FFEINFO_basictypeNONE + : ffeinfo_basictype (info)) + { + case FFEINFO_basictypeLOGICAL: + if ((error = (ffeinfo_rank (info) != 0))) + break; + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + /* Fall through. */ + case FFEINFO_basictypeREAL: + case FFEINFO_basictypeCOMPLEX: + if ((error = (ffeinfo_rank (info) != 0))) + break; + if (ffe_is_pedantic ()) + { + error = TRUE; + break; + } + /* Fall through. */ + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + if ((error = (ffeinfo_rank (info) != 0))) + break; + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + case FFEINFO_basictypeCHARACTER: + switch (ffebld_op (expr)) + { /* As if _lhs had been called instead of + _rhs. */ + case FFEBLD_opSYMTER: + error + = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT); + break; + + case FFEBLD_opSUBSTR: + error = (ffeinfo_where (ffebld_info (expr)) + == FFEINFO_whereCONSTANT_SUBOBJECT); + break; + + case FFEBLD_opARRAYREF: + error = FALSE; + break; + + default: + error = TRUE; + break; + } + if (!error + && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT) + || ((ffeinfo_rank (info) != 0) + && ((ffebld_op (expr) != FFEBLD_opSYMTER) + || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL) + || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr))) + == FFEBLD_opSTAR))))) /* Bad if + non-default-kindtype + character expr, or if + array that is not a SYMTER + (can't happen yet, I + think), or has a NULL or + STAR (assumed) array + size. */ + error = TRUE; + break; + + default: + error = TRUE; + break; + } + break; + + case FFEEXPR_contextFILEFORMAT: + switch ((expr == NULL) ? FFEINFO_basictypeNONE + : ffeinfo_basictype (info)) + { + case FFEINFO_basictypeINTEGER: + error = (expr == NULL) + || ((ffeinfo_rank (info) != 0) ? + ffe_is_pedantic () /* F77 C5. */ + : (ffeinfo_kindtype (info) != ffecom_label_kind ())) + || (ffebld_op (expr) != FFEBLD_opSYMTER); + break; + + case FFEINFO_basictypeLOGICAL: + case FFEINFO_basictypeREAL: + case FFEINFO_basictypeCOMPLEX: + /* F77 C5 -- must be an array of hollerith. */ + error + = ffe_is_pedantic () + || (ffeinfo_rank (info) == 0); + break; + + case FFEINFO_basictypeCHARACTER: + if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT) + || ((ffeinfo_rank (info) != 0) + && ((ffebld_op (expr) != FFEBLD_opSYMTER) + || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL) + || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr))) + == FFEBLD_opSTAR)))) /* Bad if + non-default-kindtype + character expr, or if + array that is not a SYMTER + (can't happen yet, I + think), or has a NULL or + STAR (assumed) array + size. */ + error = TRUE; + else + error = FALSE; + break; + + default: + error = TRUE; + break; + } + break; + + case FFEEXPR_contextLOC_: + /* See also ffeintrin_check_loc_. */ + if ((expr == NULL) + || (ffeinfo_kind (info) != FFEINFO_kindENTITY) + || ((ffebld_op (expr) != FFEBLD_opSYMTER) + && (ffebld_op (expr) != FFEBLD_opSUBSTR) + && (ffebld_op (expr) != FFEBLD_opARRAYREF))) + error = TRUE; + break; + + default: + error = FALSE; + break; + } + + if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY))) + { + ffebad_start (FFEBAD_EXPR_WRONG); + ffebad_here (0, ffelex_token_where_line (ft), + ffelex_token_where_column (ft)); + ffebad_finish (); + expr = ffebld_new_any (); + ffebld_set_info (expr, ffeinfo_new_any ()); + } + + callback = ffeexpr_stack_->callback; + s = ffeexpr_stack_->previous; + malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, + sizeof (*ffeexpr_stack_)); + ffeexpr_stack_ = s; + next = (ffelexHandler) (*callback) (ft, expr, t); + ffelex_token_kill (ft); + return (ffelexHandler) next; +} + +/* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec + + ffebld expr; + expr = ffeexpr_finished_ambig_(expr); + + Replicates a bit of ffeexpr_finished_'s task when in a context + of UNIT or FORMAT. */ + +static ffebld +ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr) +{ + ffeinfo info = ffebld_info (expr); + bool error; + + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextFILENUMAMBIG: /* Same as FILENUM in _finished_. */ + switch ((expr == NULL) ? FFEINFO_basictypeNONE + : ffeinfo_basictype (info)) + { + case FFEINFO_basictypeLOGICAL: + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + /* Fall through. */ + case FFEINFO_basictypeREAL: + case FFEINFO_basictypeCOMPLEX: + if (ffe_is_pedantic ()) + { + error = TRUE; + break; + } + /* Fall through. */ + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + error = FALSE; + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + default: + error = TRUE; + break; + } + if ((expr == NULL) || (ffeinfo_rank (info) != 0)) + error = TRUE; + break; + + case FFEEXPR_contextFILEUNITAMBIG: /* Same as FILEUNIT in _finished_. */ + if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR)) + { + error = FALSE; + break; + } + switch ((expr == NULL) ? FFEINFO_basictypeNONE + : ffeinfo_basictype (info)) + { + case FFEINFO_basictypeLOGICAL: + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL, + FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + /* Fall through. */ + case FFEINFO_basictypeREAL: + case FFEINFO_basictypeCOMPLEX: + if (ffe_is_pedantic ()) + { + error = TRUE; + break; + } + /* Fall through. */ + case FFEINFO_basictypeINTEGER: + case FFEINFO_basictypeHOLLERITH: + case FFEINFO_basictypeTYPELESS: + error = (ffeinfo_rank (info) != 0); + expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + break; + + case FFEINFO_basictypeCHARACTER: + switch (ffebld_op (expr)) + { /* As if _lhs had been called instead of + _rhs. */ + case FFEBLD_opSYMTER: + error + = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT); + break; + + case FFEBLD_opSUBSTR: + error = (ffeinfo_where (ffebld_info (expr)) + == FFEINFO_whereCONSTANT_SUBOBJECT); + break; + + case FFEBLD_opARRAYREF: + error = FALSE; + break; + + default: + error = TRUE; + break; + } + break; + + default: + error = TRUE; + break; + } + break; + + default: + assert ("bad context" == NULL); + error = TRUE; + break; + } + + if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY))) + { + ffebad_start (FFEBAD_EXPR_WRONG); + ffebad_here (0, ffelex_token_where_line (ft), + ffelex_token_where_column (ft)); + ffebad_finish (); + expr = ffebld_new_any (); + ffebld_set_info (expr, ffeinfo_new_any ()); + } + + return expr; +} + +/* ffeexpr_token_lhs_ -- Initial state for lhs expression + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Basically a smaller version of _rhs_; keep them both in sync, of course. */ + +static ffelexHandler +ffeexpr_token_lhs_ (ffelexToken t) +{ + + /* When changing the list of valid initial lhs tokens, check whether to + update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the + READ (expr) case -- it assumes it knows which tokens can + be to indicate an lhs (or implied DO), which right now is the set + {NAME,OPEN_PAREN}. + + This comment also appears in ffeexpr_token_first_lhs_. */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + case FFELEX_typeNAMES: + ffeexpr_tokens_[0] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_name_lhs_; + + default: + return (ffelexHandler) ffeexpr_finished_ (t); + } +} + +/* ffeexpr_token_rhs_ -- Initial state for rhs expression + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + The initial state and the post-binary-operator state are the same and + both handled here, with the expression stack used to distinguish + between them. Binary operators are invalid here; unary operators, + constants, subexpressions, and name references are valid. */ + +static ffelexHandler +ffeexpr_token_rhs_ (ffelexToken t) +{ + ffeexprExpr_ e; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeQUOTE: + if (ffe_is_vxt ()) + { + ffeexpr_tokens_[0] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_quote_; + } + ffeexpr_tokens_[0] = ffelex_token_use (t); + ffelex_set_expecting_hollerith (-1, '\"', + ffelex_token_where_line (t), + ffelex_token_where_column (t)); + /* Don't have to unset this one. */ + return (ffelexHandler) ffeexpr_token_apostrophe_; + + case FFELEX_typeAPOSTROPHE: + ffeexpr_tokens_[0] = ffelex_token_use (t); + ffelex_set_expecting_hollerith (-1, '\'', + ffelex_token_where_line (t), + ffelex_token_where_column (t)); + /* Don't have to unset this one. */ + return (ffelexHandler) ffeexpr_token_apostrophe_; + + case FFELEX_typePERCENT: + ffeexpr_tokens_[0] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_percent_; + + case FFELEX_typeOPEN_PAREN: + ffeexpr_stack_->tokens[0] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextPAREN_, + ffeexpr_cb_close_paren_c_); + + case FFELEX_typePLUS: + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeUNARY_; + e->token = ffelex_token_use (t); + e->u.operator.op = FFEEXPR_operatorADD_; + e->u.operator.prec = FFEEXPR_operatorprecedenceADD_; + e->u.operator.as = FFEEXPR_operatorassociativityADD_; + ffeexpr_exprstack_push_unary_ (e); + return (ffelexHandler) ffeexpr_token_rhs_; + + case FFELEX_typeMINUS: + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeUNARY_; + e->token = ffelex_token_use (t); + e->u.operator.op = FFEEXPR_operatorSUBTRACT_; + e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_; + e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_; + ffeexpr_exprstack_push_unary_ (e); + return (ffelexHandler) ffeexpr_token_rhs_; + + case FFELEX_typePERIOD: + ffeexpr_tokens_[0] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_period_; + + case FFELEX_typeNUMBER: + ffeexpr_tokens_[0] = ffelex_token_use (t); + ffeexpr_hollerith_count_ = atol (ffelex_token_text (t)); + if (ffeexpr_hollerith_count_ > 0) + ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_, + '\0', + ffelex_token_where_line (t), + ffelex_token_where_column (t)); + return (ffelexHandler) ffeexpr_token_number_; + + case FFELEX_typeNAME: + case FFELEX_typeNAMES: + ffeexpr_tokens_[0] = ffelex_token_use (t); + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextACTUALARG_: + case FFEEXPR_contextINDEXORACTUALARG_: + case FFEEXPR_contextSFUNCDEFACTUALARG_: + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + return (ffelexHandler) ffeexpr_token_name_arg_; + + default: + return (ffelexHandler) ffeexpr_token_name_rhs_; + } + + case FFELEX_typeASTERISK: + case FFELEX_typeSLASH: + case FFELEX_typePOWER: + case FFELEX_typeCONCAT: + case FFELEX_typeREL_EQ: + case FFELEX_typeREL_NE: + case FFELEX_typeREL_LE: + case FFELEX_typeREL_GE: + if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + return (ffelexHandler) ffeexpr_token_rhs_; + +#if 0 + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + case FFELEX_typeCLOSE_ANGLE: + case FFELEX_typeCLOSE_PAREN: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLON: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: +#endif + default: + return (ffelexHandler) ffeexpr_finished_ (t); + } +} + +/* ffeexpr_token_period_ -- Rhs PERIOD + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Handle a period detected at rhs (expecting unary op or operand) state. + Must begin a floating-point value (as in .12) or a dot-dot name, of + which only .NOT., .TRUE., and .FALSE. are truly valid. Other sort-of- + valid names represent binary operators, which are invalid here because + there isn't an operand at the top of the stack. */ + +static ffelexHandler +ffeexpr_token_period_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + case FFELEX_typeNAMES: + ffeexpr_current_dotdot_ = ffeexpr_dotdot_ (t); + switch (ffeexpr_current_dotdot_) + { + case FFEEXPR_dotdotNONE_: + if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), + ffelex_token_where_column (ffeexpr_tokens_[0])); + ffebad_finish (); + } + ffelex_token_kill (ffeexpr_tokens_[0]); + return (ffelexHandler) ffeexpr_token_rhs_ (t); + + case FFEEXPR_dotdotTRUE_: + case FFEEXPR_dotdotFALSE_: + case FFEEXPR_dotdotNOT_: + ffeexpr_tokens_[1] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_end_period_; + + default: + if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND)) + { + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_finish (); + } + ffelex_token_kill (ffeexpr_tokens_[0]); + return (ffelexHandler) ffeexpr_token_swallow_period_; + } + break; /* Nothing really reaches here. */ + + case FFELEX_typeNUMBER: + ffeexpr_tokens_[1] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_real_; + + default: + if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), + ffelex_token_where_column (ffeexpr_tokens_[0])); + ffebad_finish (); + } + ffelex_token_kill (ffeexpr_tokens_[0]); + return (ffelexHandler) ffeexpr_token_rhs_ (t); + } +} + +/* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE) + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op + or operator) state. If period isn't found, issue a diagnostic but + pretend we saw one. ffeexpr_current_dotdot_ must already contained the + dotdot representation of the name in between the two PERIOD tokens. */ + +static ffelexHandler +ffeexpr_token_end_period_ (ffelexToken t) +{ + ffeexprExpr_ e; + + if (ffelex_token_type (t) != FFELEX_typePERIOD) + { + if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), + ffelex_token_where_column (ffeexpr_tokens_[0])); + ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_string (ffelex_token_text (ffeexpr_tokens_[1])); + ffebad_finish (); + } + } + + ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill "NOT"/"TRUE"/"FALSE" + token. */ + + e = ffeexpr_expr_new_ (); + e->token = ffeexpr_tokens_[0]; + + switch (ffeexpr_current_dotdot_) + { + case FFEEXPR_dotdotNOT_: + e->type = FFEEXPR_exprtypeUNARY_; + e->u.operator.op = FFEEXPR_operatorNOT_; + e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_; + e->u.operator.as = FFEEXPR_operatorassociativityNOT_; + ffeexpr_exprstack_push_unary_ (e); + if (ffelex_token_type (t) != FFELEX_typePERIOD) + return (ffelexHandler) ffeexpr_token_rhs_ (t); + return (ffelexHandler) ffeexpr_token_rhs_; + + case FFEEXPR_dotdotTRUE_: + e->type = FFEEXPR_exprtypeOPERAND_; + e->u.operand + = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE)); + ffebld_set_info (e->u.operand, + ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, + 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); + ffeexpr_exprstack_push_operand_ (e); + if (ffelex_token_type (t) != FFELEX_typePERIOD) + return (ffelexHandler) ffeexpr_token_binary_ (t); + return (ffelexHandler) ffeexpr_token_binary_; + + case FFEEXPR_dotdotFALSE_: + e->type = FFEEXPR_exprtypeOPERAND_; + e->u.operand + = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE)); + ffebld_set_info (e->u.operand, + ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT, + 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); + ffeexpr_exprstack_push_operand_ (e); + if (ffelex_token_type (t) != FFELEX_typePERIOD) + return (ffelexHandler) ffeexpr_token_binary_ (t); + return (ffelexHandler) ffeexpr_token_binary_; + + default: + assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL); + exit (0); + return NULL; + } +} + +/* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE) + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + A diagnostic has already been issued; just swallow a period if there is + one, then continue with ffeexpr_token_rhs_. */ + +static ffelexHandler +ffeexpr_token_swallow_period_ (ffelexToken t) +{ + if (ffelex_token_type (t) != FFELEX_typePERIOD) + return (ffelexHandler) ffeexpr_token_rhs_ (t); + + return (ffelexHandler) ffeexpr_token_rhs_; +} + +/* ffeexpr_token_real_ -- Rhs PERIOD NUMBER + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + After a period and a string of digits, check next token for possible + exponent designation (D, E, or Q as first/only character) and continue + real-number handling accordingly. Else form basic real constant, push + onto expression stack, and enter binary state using current token (which, + if it is a name not beginning with D, E, or Q, will certainly result + in an error, but that's not for this routine to deal with). */ + +static ffelexHandler +ffeexpr_token_real_ (ffelexToken t) +{ + char d; + char *p; + + if (((ffelex_token_type (t) != FFELEX_typeNAME) + && (ffelex_token_type (t) != FFELEX_typeNAMES)) + || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), + 'D', 'd') + || ffesrc_char_match_init (d, 'E', 'e') + || ffesrc_char_match_init (d, 'Q', 'q'))) + && ffeexpr_isdigits_ (++p))) + { +#if 0 + /* This code has been removed because it seems inconsistent to + produce a diagnostic in this case, but not all of the other + ones that look for an exponent and cannot recognize one. */ + if (((ffelex_token_type (t) == FFELEX_typeNAME) + || (ffelex_token_type (t) == FFELEX_typeNAMES)) + && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT)) + { + char bad[2]; + + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]), + ffelex_token_where_column (ffeexpr_tokens_[0])); + bad[0] = *(p - 1); + bad[1] = '\0'; + ffebad_string (bad); + ffebad_finish (); + } +#endif + ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL, + ffeexpr_tokens_[0], ffeexpr_tokens_[1], + NULL, NULL, NULL); + + ffelex_token_kill (ffeexpr_tokens_[0]); + ffelex_token_kill (ffeexpr_tokens_[1]); + return (ffelexHandler) ffeexpr_token_binary_ (t); + } + + /* Just exponent character by itself? In which case, PLUS or MINUS must + surely be next, followed by a NUMBER token. */ + + if (*p == '\0') + { + ffeexpr_tokens_[2] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_real_exponent_; + } + + ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1], + t, NULL, NULL); + + ffelex_token_kill (ffeexpr_tokens_[0]); + ffelex_token_kill (ffeexpr_tokens_[1]); + return (ffelexHandler) ffeexpr_token_binary_; +} + +/* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q) + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Ensures this token is PLUS or MINUS, preserves it, goes to final state + for real number (exponent digits). Else issues diagnostic, assumes a + zero exponent field for number, passes token on to binary state as if + previous token had been "E0" instead of "E", for example. */ + +static ffelexHandler +ffeexpr_token_real_exponent_ (ffelexToken t) +{ + if ((ffelex_token_type (t) != FFELEX_typePLUS) + && (ffelex_token_type (t) != FFELEX_typeMINUS)) + { + if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]), + ffelex_token_where_column (ffeexpr_tokens_[2])); + ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL, + ffeexpr_tokens_[0], ffeexpr_tokens_[1], + NULL, NULL, NULL); + + ffelex_token_kill (ffeexpr_tokens_[0]); + ffelex_token_kill (ffeexpr_tokens_[1]); + ffelex_token_kill (ffeexpr_tokens_[2]); + return (ffelexHandler) ffeexpr_token_binary_ (t); + } + + ffeexpr_tokens_[3] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_real_exp_sign_; +} + +/* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Make sure token is a NUMBER, make a real constant out of all we have and + push it onto the expression stack. Else issue diagnostic and pretend + exponent field was a zero. */ + +static ffelexHandler +ffeexpr_token_real_exp_sign_ (ffelexToken t) +{ + if (ffelex_token_type (t) != FFELEX_typeNUMBER) + { + if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]), + ffelex_token_where_column (ffeexpr_tokens_[2])); + ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL, + ffeexpr_tokens_[0], ffeexpr_tokens_[1], + NULL, NULL, NULL); + + ffelex_token_kill (ffeexpr_tokens_[0]); + ffelex_token_kill (ffeexpr_tokens_[1]); + ffelex_token_kill (ffeexpr_tokens_[2]); + ffelex_token_kill (ffeexpr_tokens_[3]); + return (ffelexHandler) ffeexpr_token_binary_ (t); + } + + ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL, + ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2], + ffeexpr_tokens_[3], t); + + ffelex_token_kill (ffeexpr_tokens_[0]); + ffelex_token_kill (ffeexpr_tokens_[1]); + ffelex_token_kill (ffeexpr_tokens_[2]); + ffelex_token_kill (ffeexpr_tokens_[3]); + return (ffelexHandler) ffeexpr_token_binary_; +} + +/* ffeexpr_token_number_ -- Rhs NUMBER + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + If the token is a period, we may have a floating-point number, or an + integer followed by a dotdot binary operator. If the token is a name + beginning with D, E, or Q, we definitely have a floating-point number. + If the token is a hollerith constant, that's what we've got, so push + it onto the expression stack and continue with the binary state. + + Otherwise, we have an integer followed by something the binary state + should be able to swallow. */ + +static ffelexHandler +ffeexpr_token_number_ (ffelexToken t) +{ + ffeexprExpr_ e; + ffeinfo ni; + char d; + char *p; + + if (ffeexpr_hollerith_count_ > 0) + ffelex_set_expecting_hollerith (0, '\0', + ffewhere_line_unknown (), + ffewhere_column_unknown ()); + + /* See if we've got a floating-point number here. */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + case FFELEX_typeNAMES: + if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), + 'D', 'd') + || ffesrc_char_match_init (d, 'E', 'e') + || ffesrc_char_match_init (d, 'Q', 'q')) + && ffeexpr_isdigits_ (++p)) + { + + /* Just exponent character by itself? In which case, PLUS or MINUS + must surely be next, followed by a NUMBER token. */ + + if (*p == '\0') + { + ffeexpr_tokens_[1] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_number_exponent_; + } + ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t, + NULL, NULL); + + ffelex_token_kill (ffeexpr_tokens_[0]); + return (ffelexHandler) ffeexpr_token_binary_; + } + break; + + case FFELEX_typePERIOD: + ffeexpr_tokens_[1] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_number_period_; + + case FFELEX_typeHOLLERITH: + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + e->token = ffeexpr_tokens_[0]; + e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t)); + ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE, + 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, + ffelex_token_length (t)); + ffebld_set_info (e->u.operand, ni); + ffeexpr_exprstack_push_operand_ (e); + return (ffelexHandler) ffeexpr_token_binary_; + + default: + break; + } + + /* Nothing specific we were looking for, so make an integer and pass the + current token to the binary state. */ + + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + e->token = ffeexpr_tokens_[0]; + e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault + (ffeexpr_tokens_[0])); + ffebld_set_info (e->u.operand, + ffeinfo_new (FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, + FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + ffeexpr_exprstack_push_operand_ (e); + return (ffelexHandler) ffeexpr_token_binary_ (t); +} + +/* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q) + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Ensures this token is PLUS or MINUS, preserves it, goes to final state + for real number (exponent digits). Else treats number as integer, passes + name to binary, passes current token to subsequent handler. */ + +static ffelexHandler +ffeexpr_token_number_exponent_ (ffelexToken t) +{ + if ((ffelex_token_type (t) != FFELEX_typePLUS) + && (ffelex_token_type (t) != FFELEX_typeMINUS)) + { + ffeexprExpr_ e; + ffelexHandler nexthandler; + + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + e->token = ffeexpr_tokens_[0]; + e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault + (ffeexpr_tokens_[0])); + ffebld_set_info (e->u.operand, + ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, + 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); + ffeexpr_exprstack_push_operand_ (e); + nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]); + ffelex_token_kill (ffeexpr_tokens_[1]); + return (ffelexHandler) (*nexthandler) (t); + } + + ffeexpr_tokens_[2] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_number_exp_sign_; +} + +/* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Make sure token is a NUMBER, make a real constant out of all we have and + push it onto the expression stack. Else issue diagnostic and pretend + exponent field was a zero. */ + +static ffelexHandler +ffeexpr_token_number_exp_sign_ (ffelexToken t) +{ + if (ffelex_token_type (t) != FFELEX_typeNUMBER) + { + if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]), + ffelex_token_where_column (ffeexpr_tokens_[1])); + ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0], + ffeexpr_tokens_[0], NULL, NULL, + ffeexpr_tokens_[1], ffeexpr_tokens_[2], + NULL); + + ffelex_token_kill (ffeexpr_tokens_[0]); + ffelex_token_kill (ffeexpr_tokens_[1]); + ffelex_token_kill (ffeexpr_tokens_[2]); + return (ffelexHandler) ffeexpr_token_binary_ (t); + } + + ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0], + ffeexpr_tokens_[0], NULL, NULL, + ffeexpr_tokens_[1], ffeexpr_tokens_[2], t); + + ffelex_token_kill (ffeexpr_tokens_[0]); + ffelex_token_kill (ffeexpr_tokens_[1]); + ffelex_token_kill (ffeexpr_tokens_[2]); + return (ffelexHandler) ffeexpr_token_binary_; +} + +/* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Handle a period detected following a number at rhs state. Must begin a + floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name. */ + +static ffelexHandler +ffeexpr_token_number_period_ (ffelexToken t) +{ + ffeexprExpr_ e; + ffelexHandler nexthandler; + char *p; + char d; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + case FFELEX_typeNAMES: + if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), + 'D', 'd') + || ffesrc_char_match_init (d, 'E', 'e') + || ffesrc_char_match_init (d, 'Q', 'q')) + && ffeexpr_isdigits_ (++p)) + { + + /* Just exponent character by itself? In which case, PLUS or MINUS + must surely be next, followed by a NUMBER token. */ + + if (*p == '\0') + { + ffeexpr_tokens_[2] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_number_per_exp_; + } + ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], + ffeexpr_tokens_[1], NULL, t, NULL, + NULL); + + ffelex_token_kill (ffeexpr_tokens_[0]); + ffelex_token_kill (ffeexpr_tokens_[1]); + return (ffelexHandler) ffeexpr_token_binary_; + } + /* A name not representing an exponent, so assume it will be something + like EQ, make an integer from the number, pass the period to binary + state and the current token to the resulting state. */ + + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + e->token = ffeexpr_tokens_[0]; + e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault + (ffeexpr_tokens_[0])); + ffebld_set_info (e->u.operand, + ffeinfo_new (FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, + FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + ffeexpr_exprstack_push_operand_ (e); + nexthandler = (ffelexHandler) ffeexpr_token_binary_ + (ffeexpr_tokens_[1]); + ffelex_token_kill (ffeexpr_tokens_[1]); + return (ffelexHandler) (*nexthandler) (t); + + case FFELEX_typeNUMBER: + ffeexpr_tokens_[2] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_number_real_; + + default: + break; + } + + /* Nothing specific we were looking for, so make a real number and pass the + period and then the current token to the binary state. */ + + ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), + ffeexpr_tokens_[0], ffeexpr_tokens_[1], + NULL, NULL, NULL, NULL); + + ffelex_token_kill (ffeexpr_tokens_[0]); + ffelex_token_kill (ffeexpr_tokens_[1]); + return (ffelexHandler) ffeexpr_token_binary_ (t); +} + +/* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q) + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Ensures this token is PLUS or MINUS, preserves it, goes to final state + for real number (exponent digits). Else treats number as real, passes + name to binary, passes current token to subsequent handler. */ + +static ffelexHandler +ffeexpr_token_number_per_exp_ (ffelexToken t) +{ + if ((ffelex_token_type (t) != FFELEX_typePLUS) + && (ffelex_token_type (t) != FFELEX_typeMINUS)) + { + ffelexHandler nexthandler; + + ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), + ffeexpr_tokens_[0], ffeexpr_tokens_[1], + NULL, NULL, NULL, NULL); + + ffelex_token_kill (ffeexpr_tokens_[0]); + ffelex_token_kill (ffeexpr_tokens_[1]); + nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]); + ffelex_token_kill (ffeexpr_tokens_[2]); + return (ffelexHandler) (*nexthandler) (t); + } + + ffeexpr_tokens_[3] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_num_per_exp_sign_; +} + +/* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + After a number, period, and number, check next token for possible + exponent designation (D, E, or Q as first/only character) and continue + real-number handling accordingly. Else form basic real constant, push + onto expression stack, and enter binary state using current token (which, + if it is a name not beginning with D, E, or Q, will certainly result + in an error, but that's not for this routine to deal with). */ + +static ffelexHandler +ffeexpr_token_number_real_ (ffelexToken t) +{ + char d; + char *p; + + if (((ffelex_token_type (t) != FFELEX_typeNAME) + && (ffelex_token_type (t) != FFELEX_typeNAMES)) + || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))), + 'D', 'd') + || ffesrc_char_match_init (d, 'E', 'e') + || ffesrc_char_match_init (d, 'Q', 'q'))) + && ffeexpr_isdigits_ (++p))) + { +#if 0 + /* This code has been removed because it seems inconsistent to + produce a diagnostic in this case, but not all of the other + ones that look for an exponent and cannot recognize one. */ + if (((ffelex_token_type (t) == FFELEX_typeNAME) + || (ffelex_token_type (t) == FFELEX_typeNAMES)) + && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT)) + { + char bad[2]; + + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]), + ffelex_token_where_column (ffeexpr_tokens_[0])); + bad[0] = *(p - 1); + bad[1] = '\0'; + ffebad_string (bad); + ffebad_finish (); + } +#endif + ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), + ffeexpr_tokens_[0], ffeexpr_tokens_[1], + ffeexpr_tokens_[2], NULL, NULL, NULL); + + ffelex_token_kill (ffeexpr_tokens_[0]); + ffelex_token_kill (ffeexpr_tokens_[1]); + ffelex_token_kill (ffeexpr_tokens_[2]); + return (ffelexHandler) ffeexpr_token_binary_ (t); + } + + /* Just exponent character by itself? In which case, PLUS or MINUS must + surely be next, followed by a NUMBER token. */ + + if (*p == '\0') + { + ffeexpr_tokens_[3] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_number_real_exp_; + } + + ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1], + ffeexpr_tokens_[2], t, NULL, NULL); + + ffelex_token_kill (ffeexpr_tokens_[0]); + ffelex_token_kill (ffeexpr_tokens_[1]); + ffelex_token_kill (ffeexpr_tokens_[2]); + return (ffelexHandler) ffeexpr_token_binary_; +} + +/* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Make sure token is a NUMBER, make a real constant out of all we have and + push it onto the expression stack. Else issue diagnostic and pretend + exponent field was a zero. */ + +static ffelexHandler +ffeexpr_token_num_per_exp_sign_ (ffelexToken t) +{ + if (ffelex_token_type (t) != FFELEX_typeNUMBER) + { + if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]), + ffelex_token_where_column (ffeexpr_tokens_[2])); + ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), + ffeexpr_tokens_[0], ffeexpr_tokens_[1], + NULL, NULL, NULL, NULL); + + ffelex_token_kill (ffeexpr_tokens_[0]); + ffelex_token_kill (ffeexpr_tokens_[1]); + ffelex_token_kill (ffeexpr_tokens_[2]); + ffelex_token_kill (ffeexpr_tokens_[3]); + return (ffelexHandler) ffeexpr_token_binary_ (t); + } + + ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], + ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL, + ffeexpr_tokens_[2], ffeexpr_tokens_[3], t); + + ffelex_token_kill (ffeexpr_tokens_[0]); + ffelex_token_kill (ffeexpr_tokens_[1]); + ffelex_token_kill (ffeexpr_tokens_[2]); + ffelex_token_kill (ffeexpr_tokens_[3]); + return (ffelexHandler) ffeexpr_token_binary_; +} + +/* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q) + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Ensures this token is PLUS or MINUS, preserves it, goes to final state + for real number (exponent digits). Else issues diagnostic, assumes a + zero exponent field for number, passes token on to binary state as if + previous token had been "E0" instead of "E", for example. */ + +static ffelexHandler +ffeexpr_token_number_real_exp_ (ffelexToken t) +{ + if ((ffelex_token_type (t) != FFELEX_typePLUS) + && (ffelex_token_type (t) != FFELEX_typeMINUS)) + { + if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]), + ffelex_token_where_column (ffeexpr_tokens_[3])); + ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), + ffeexpr_tokens_[0], ffeexpr_tokens_[1], + ffeexpr_tokens_[2], NULL, NULL, NULL); + + ffelex_token_kill (ffeexpr_tokens_[0]); + ffelex_token_kill (ffeexpr_tokens_[1]); + ffelex_token_kill (ffeexpr_tokens_[2]); + ffelex_token_kill (ffeexpr_tokens_[3]); + return (ffelexHandler) ffeexpr_token_binary_ (t); + } + + ffeexpr_tokens_[4] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_num_real_exp_sn_; +} + +/* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q) + PLUS/MINUS + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Make sure token is a NUMBER, make a real constant out of all we have and + push it onto the expression stack. Else issue diagnostic and pretend + exponent field was a zero. */ + +static ffelexHandler +ffeexpr_token_num_real_exp_sn_ (ffelexToken t) +{ + if (ffelex_token_type (t) != FFELEX_typeNUMBER) + { + if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]), + ffelex_token_where_column (ffeexpr_tokens_[3])); + ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), + ffeexpr_tokens_[0], ffeexpr_tokens_[1], + ffeexpr_tokens_[2], NULL, NULL, NULL); + + ffelex_token_kill (ffeexpr_tokens_[0]); + ffelex_token_kill (ffeexpr_tokens_[1]); + ffelex_token_kill (ffeexpr_tokens_[2]); + ffelex_token_kill (ffeexpr_tokens_[3]); + ffelex_token_kill (ffeexpr_tokens_[4]); + return (ffelexHandler) ffeexpr_token_binary_ (t); + } + + ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0], + ffeexpr_tokens_[0], ffeexpr_tokens_[1], + ffeexpr_tokens_[2], ffeexpr_tokens_[3], + ffeexpr_tokens_[4], t); + + ffelex_token_kill (ffeexpr_tokens_[0]); + ffelex_token_kill (ffeexpr_tokens_[1]); + ffelex_token_kill (ffeexpr_tokens_[2]); + ffelex_token_kill (ffeexpr_tokens_[3]); + ffelex_token_kill (ffeexpr_tokens_[4]); + return (ffelexHandler) ffeexpr_token_binary_; +} + +/* ffeexpr_token_binary_ -- Handle binary operator possibility + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + The possibility of a binary operator is handled here, meaning the previous + token was an operand. */ + +static ffelexHandler +ffeexpr_token_binary_ (ffelexToken t) +{ + ffeexprExpr_ e; + + if (!ffeexpr_stack_->is_rhs) + return (ffelexHandler) ffeexpr_finished_ (t); /* For now. */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typePLUS: + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeBINARY_; + e->token = ffelex_token_use (t); + e->u.operator.op = FFEEXPR_operatorADD_; + e->u.operator.prec = FFEEXPR_operatorprecedenceADD_; + e->u.operator.as = FFEEXPR_operatorassociativityADD_; + ffeexpr_exprstack_push_binary_ (e); + return (ffelexHandler) ffeexpr_token_rhs_; + + case FFELEX_typeMINUS: + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeBINARY_; + e->token = ffelex_token_use (t); + e->u.operator.op = FFEEXPR_operatorSUBTRACT_; + e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_; + e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_; + ffeexpr_exprstack_push_binary_ (e); + return (ffelexHandler) ffeexpr_token_rhs_; + + case FFELEX_typeASTERISK: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextDATA: + return (ffelexHandler) ffeexpr_finished_ (t); + + default: + break; + } + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeBINARY_; + e->token = ffelex_token_use (t); + e->u.operator.op = FFEEXPR_operatorMULTIPLY_; + e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_; + e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_; + ffeexpr_exprstack_push_binary_ (e); + return (ffelexHandler) ffeexpr_token_rhs_; + + case FFELEX_typeSLASH: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextDATA: + return (ffelexHandler) ffeexpr_finished_ (t); + + default: + break; + } + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeBINARY_; + e->token = ffelex_token_use (t); + e->u.operator.op = FFEEXPR_operatorDIVIDE_; + e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_; + e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_; + ffeexpr_exprstack_push_binary_ (e); + return (ffelexHandler) ffeexpr_token_rhs_; + + case FFELEX_typePOWER: + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeBINARY_; + e->token = ffelex_token_use (t); + e->u.operator.op = FFEEXPR_operatorPOWER_; + e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_; + e->u.operator.as = FFEEXPR_operatorassociativityPOWER_; + ffeexpr_exprstack_push_binary_ (e); + return (ffelexHandler) ffeexpr_token_rhs_; + + case FFELEX_typeCONCAT: + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeBINARY_; + e->token = ffelex_token_use (t); + e->u.operator.op = FFEEXPR_operatorCONCATENATE_; + e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_; + e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_; + ffeexpr_exprstack_push_binary_ (e); + return (ffelexHandler) ffeexpr_token_rhs_; + + case FFELEX_typeOPEN_ANGLE: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextFORMAT: + ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + break; + + default: + break; + } + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeBINARY_; + e->token = ffelex_token_use (t); + e->u.operator.op = FFEEXPR_operatorLT_; + e->u.operator.prec = FFEEXPR_operatorprecedenceLT_; + e->u.operator.as = FFEEXPR_operatorassociativityLT_; + ffeexpr_exprstack_push_binary_ (e); + return (ffelexHandler) ffeexpr_token_rhs_; + + case FFELEX_typeCLOSE_ANGLE: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextFORMAT: + return ffeexpr_finished_ (t); + + default: + break; + } + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeBINARY_; + e->token = ffelex_token_use (t); + e->u.operator.op = FFEEXPR_operatorGT_; + e->u.operator.prec = FFEEXPR_operatorprecedenceGT_; + e->u.operator.as = FFEEXPR_operatorassociativityGT_; + ffeexpr_exprstack_push_binary_ (e); + return (ffelexHandler) ffeexpr_token_rhs_; + + case FFELEX_typeREL_EQ: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextFORMAT: + ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + break; + + default: + break; + } + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeBINARY_; + e->token = ffelex_token_use (t); + e->u.operator.op = FFEEXPR_operatorEQ_; + e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_; + e->u.operator.as = FFEEXPR_operatorassociativityEQ_; + ffeexpr_exprstack_push_binary_ (e); + return (ffelexHandler) ffeexpr_token_rhs_; + + case FFELEX_typeREL_NE: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextFORMAT: + ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + break; + + default: + break; + } + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeBINARY_; + e->token = ffelex_token_use (t); + e->u.operator.op = FFEEXPR_operatorNE_; + e->u.operator.prec = FFEEXPR_operatorprecedenceNE_; + e->u.operator.as = FFEEXPR_operatorassociativityNE_; + ffeexpr_exprstack_push_binary_ (e); + return (ffelexHandler) ffeexpr_token_rhs_; + + case FFELEX_typeREL_LE: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextFORMAT: + ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + break; + + default: + break; + } + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeBINARY_; + e->token = ffelex_token_use (t); + e->u.operator.op = FFEEXPR_operatorLE_; + e->u.operator.prec = FFEEXPR_operatorprecedenceLE_; + e->u.operator.as = FFEEXPR_operatorassociativityLE_; + ffeexpr_exprstack_push_binary_ (e); + return (ffelexHandler) ffeexpr_token_rhs_; + + case FFELEX_typeREL_GE: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextFORMAT: + ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + break; + + default: + break; + } + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeBINARY_; + e->token = ffelex_token_use (t); + e->u.operator.op = FFEEXPR_operatorGE_; + e->u.operator.prec = FFEEXPR_operatorprecedenceGE_; + e->u.operator.as = FFEEXPR_operatorassociativityGE_; + ffeexpr_exprstack_push_binary_ (e); + return (ffelexHandler) ffeexpr_token_rhs_; + + case FFELEX_typePERIOD: + ffeexpr_tokens_[0] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_binary_period_; + +#if 0 + case FFELEX_typeOPEN_PAREN: + case FFELEX_typeCLOSE_PAREN: + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLON: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeNAME: + case FFELEX_typeNAMES: +#endif + default: + return (ffelexHandler) ffeexpr_finished_ (t); + } +} + +/* ffeexpr_token_binary_period_ -- Binary PERIOD + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Handle a period detected at binary (expecting binary op or end) state. + Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not + valid. */ + +static ffelexHandler +ffeexpr_token_binary_period_ (ffelexToken t) +{ + ffeexprExpr_ operand; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + case FFELEX_typeNAMES: + ffeexpr_current_dotdot_ = ffeexpr_dotdot_ (t); + switch (ffeexpr_current_dotdot_) + { + case FFEEXPR_dotdotTRUE_: + case FFEEXPR_dotdotFALSE_: + case FFEEXPR_dotdotNOT_: + if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR)) + { + operand = ffeexpr_stack_->exprstack; + assert (operand != NULL); + assert (operand->type == FFEEXPR_exprtypeOPERAND_); + ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token)); + ffebad_here (1, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_finish (); + } + ffelex_token_kill (ffeexpr_tokens_[0]); + return (ffelexHandler) ffeexpr_token_binary_sw_per_; + + case FFEEXPR_dotdotNONE_: + if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT)) + { + ffebad_string (ffelex_token_text (t)); + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), + ffelex_token_where_column (ffeexpr_tokens_[0])); + ffebad_finish (); + } + ffeexpr_current_dotdot_ = FFEEXPR_dotdotEQ_; + /* Fall through here, pretending we got a .EQ. operator. */ + default: + ffeexpr_tokens_[1] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_binary_end_per_; + } + break; /* Nothing really reaches here. */ + + default: + if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), + ffelex_token_where_column (ffeexpr_tokens_[0])); + ffebad_finish (); + } + ffelex_token_kill (ffeexpr_tokens_[0]); + return (ffelexHandler) ffeexpr_token_binary_ (t); + } +} + +/* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE) + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Expecting a period to close a dot-dot at binary (binary op + or operator) state. If period isn't found, issue a diagnostic but + pretend we saw one. ffeexpr_current_dotdot_ must already contained the + dotdot representation of the name in between the two PERIOD tokens. */ + +static ffelexHandler +ffeexpr_token_binary_end_per_ (ffelexToken t) +{ + ffeexprExpr_ e; + + if (ffelex_token_type (t) != FFELEX_typePERIOD) + { + if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), + ffelex_token_where_column (ffeexpr_tokens_[0])); + ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_string (ffelex_token_text (ffeexpr_tokens_[1])); + ffebad_finish (); + } + } + + ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */ + + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeBINARY_; + e->token = ffeexpr_tokens_[0]; + + switch (ffeexpr_current_dotdot_) + { + case FFEEXPR_dotdotAND_: + e->u.operator.op = FFEEXPR_operatorAND_; + e->u.operator.prec = FFEEXPR_operatorprecedenceAND_; + e->u.operator.as = FFEEXPR_operatorassociativityAND_; + break; + + case FFEEXPR_dotdotOR_: + e->u.operator.op = FFEEXPR_operatorOR_; + e->u.operator.prec = FFEEXPR_operatorprecedenceOR_; + e->u.operator.as = FFEEXPR_operatorassociativityOR_; + break; + + case FFEEXPR_dotdotXOR_: + e->u.operator.op = FFEEXPR_operatorXOR_; + e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_; + e->u.operator.as = FFEEXPR_operatorassociativityXOR_; + break; + + case FFEEXPR_dotdotEQV_: + e->u.operator.op = FFEEXPR_operatorEQV_; + e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_; + e->u.operator.as = FFEEXPR_operatorassociativityEQV_; + break; + + case FFEEXPR_dotdotNEQV_: + e->u.operator.op = FFEEXPR_operatorNEQV_; + e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_; + e->u.operator.as = FFEEXPR_operatorassociativityNEQV_; + break; + + case FFEEXPR_dotdotLT_: + e->u.operator.op = FFEEXPR_operatorLT_; + e->u.operator.prec = FFEEXPR_operatorprecedenceLT_; + e->u.operator.as = FFEEXPR_operatorassociativityLT_; + break; + + case FFEEXPR_dotdotLE_: + e->u.operator.op = FFEEXPR_operatorLE_; + e->u.operator.prec = FFEEXPR_operatorprecedenceLE_; + e->u.operator.as = FFEEXPR_operatorassociativityLE_; + break; + + case FFEEXPR_dotdotEQ_: + e->u.operator.op = FFEEXPR_operatorEQ_; + e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_; + e->u.operator.as = FFEEXPR_operatorassociativityEQ_; + break; + + case FFEEXPR_dotdotNE_: + e->u.operator.op = FFEEXPR_operatorNE_; + e->u.operator.prec = FFEEXPR_operatorprecedenceNE_; + e->u.operator.as = FFEEXPR_operatorassociativityNE_; + break; + + case FFEEXPR_dotdotGT_: + e->u.operator.op = FFEEXPR_operatorGT_; + e->u.operator.prec = FFEEXPR_operatorprecedenceGT_; + e->u.operator.as = FFEEXPR_operatorassociativityGT_; + break; + + case FFEEXPR_dotdotGE_: + e->u.operator.op = FFEEXPR_operatorGE_; + e->u.operator.prec = FFEEXPR_operatorprecedenceGE_; + e->u.operator.as = FFEEXPR_operatorassociativityGE_; + break; + + default: + assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL); + } + + ffeexpr_exprstack_push_binary_ (e); + + if (ffelex_token_type (t) != FFELEX_typePERIOD) + return (ffelexHandler) ffeexpr_token_rhs_ (t); + return (ffelexHandler) ffeexpr_token_rhs_; +} + +/* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE) + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + A diagnostic has already been issued; just swallow a period if there is + one, then continue with ffeexpr_token_binary_. */ + +static ffelexHandler +ffeexpr_token_binary_sw_per_ (ffelexToken t) +{ + if (ffelex_token_type (t) != FFELEX_typePERIOD) + return (ffelexHandler) ffeexpr_token_binary_ (t); + + return (ffelexHandler) ffeexpr_token_binary_; +} + +/* ffeexpr_token_quote_ -- Rhs QUOTE + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Expecting a NUMBER that we'll treat as an octal integer. */ + +static ffelexHandler +ffeexpr_token_quote_ (ffelexToken t) +{ + ffeexprExpr_ e; + ffebld anyexpr; + + if (ffelex_token_type (t) != FFELEX_typeNUMBER) + { + if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), + ffelex_token_where_column (ffeexpr_tokens_[0])); + ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + ffelex_token_kill (ffeexpr_tokens_[0]); + return (ffelexHandler) ffeexpr_token_rhs_ (t); + } + + /* This is kind of a kludge to prevent any whining about magical numbers + that start out as these octal integers, so "20000000000 (on a 32-bit + 2's-complement machine) by itself won't produce an error. */ + + anyexpr = ffebld_new_any (); + ffebld_set_info (anyexpr, ffeinfo_new_any ()); + + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + e->token = ffeexpr_tokens_[0]; + e->u.operand = ffebld_new_conter_with_orig + (ffebld_constant_new_integeroctal (t), anyexpr); + ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); + ffeexpr_exprstack_push_operand_ (e); + return (ffelexHandler) ffeexpr_token_binary_; +} + +/* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Handle an open-apostrophe, which begins either a character ('char-const'), + typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or + 'hex-const'X) constant. */ + +static ffelexHandler +ffeexpr_token_apostrophe_ (ffelexToken t) +{ + assert (ffelex_token_type (t) == FFELEX_typeCHARACTER); + if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0)) + { + ffebad_start (FFEBAD_NULL_CHAR_CONST); + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_finish (); + } + ffeexpr_tokens_[1] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_apos_char_; +} + +/* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Close-apostrophe is implicit; if this token is NAME, it is a possible + typeless-constant radix specifier. */ + +static ffelexHandler +ffeexpr_token_apos_char_ (ffelexToken t) +{ + ffeexprExpr_ e; + ffeinfo ni; + char c; + ffetargetCharacterSize size; + + if ((ffelex_token_type (t) == FFELEX_typeNAME) + || (ffelex_token_type (t) == FFELEX_typeNAMES)) + { + if ((ffelex_token_length (t) == 1) + && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B', + 'b') + || ffesrc_char_match_init (c, 'O', 'o') + || ffesrc_char_match_init (c, 'X', 'x') + || ffesrc_char_match_init (c, 'Z', 'z'))) + { + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + e->token = ffeexpr_tokens_[0]; + switch (c) + { + case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match): + e->u.operand = ffebld_new_conter + (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1])); + size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]); + break; + + case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match): + e->u.operand = ffebld_new_conter + (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1])); + size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]); + break; + + case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match): + e->u.operand = ffebld_new_conter + (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1])); + size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]); + break; + + case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match): + e->u.operand = ffebld_new_conter + (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1])); + size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]); + break; + + default: + no_match: /* :::::::::::::::::::: */ + assert ("not BOXZ!" == NULL); + size = 0; + break; + } + ffebld_set_info (e->u.operand, + ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE, + 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size)); + ffeexpr_exprstack_push_operand_ (e); + ffelex_token_kill (ffeexpr_tokens_[1]); + return (ffelexHandler) ffeexpr_token_binary_; + } + } + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + e->token = ffeexpr_tokens_[0]; + e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault + (ffeexpr_tokens_[1])); + ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT, + 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, + ffelex_token_length (ffeexpr_tokens_[1])); + ffebld_set_info (e->u.operand, ni); + ffelex_token_kill (ffeexpr_tokens_[1]); + ffeexpr_exprstack_push_operand_ (e); + if ((ffelex_token_type (t) == FFELEX_typeNAME) + || (ffelex_token_type (t) == FFELEX_typeNAMES)) + { + if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER)) + { + ffebad_string (ffelex_token_text (t)); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]), + ffelex_token_where_column (ffeexpr_tokens_[0])); + ffebad_finish (); + } + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeBINARY_; + e->token = ffelex_token_use (t); + e->u.operator.op = FFEEXPR_operatorCONCATENATE_; + e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_; + e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_; + ffeexpr_exprstack_push_binary_ (e); + return (ffelexHandler) ffeexpr_token_rhs_ (t); + } + ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 (); /* Allow "'hello'(3:5)". */ + return (ffelexHandler) ffeexpr_token_substrp_ (t); +} + +/* ffeexpr_token_name_lhs_ -- Lhs NAME + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Handle a name followed by open-paren, period (RECORD.MEMBER), percent + (RECORD%MEMBER), or nothing at all. */ + +static ffelexHandler +ffeexpr_token_name_lhs_ (ffelexToken t) +{ + ffeexprExpr_ e; + ffeexprParenType_ paren_type; + ffesymbol s; + ffebld expr; + ffeinfo info; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextASSIGN: + case FFEEXPR_contextAGOTO: + case FFEEXPR_contextFILEUNIT_DF: + goto just_name; /* :::::::::::::::::::: */ + + default: + break; + } + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + e->token = ffelex_token_use (ffeexpr_tokens_[0]); + s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE, + &paren_type); + + switch (ffesymbol_where (s)) + { + case FFEINFO_whereLOCAL: + if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF) + ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recursion. */ + break; + + case FFEINFO_whereINTRINSIC: + case FFEINFO_whereGLOBAL: + if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF) + ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */ + break; + + case FFEINFO_whereCOMMON: + case FFEINFO_whereDUMMY: + case FFEINFO_whereRESULT: + break; + + case FFEINFO_whereNONE: + case FFEINFO_whereANY: + break; + + default: + ffesymbol_error (s, ffeexpr_tokens_[0]); + break; + } + + if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY) + { + e->u.operand = ffebld_new_any (); + ffebld_set_info (e->u.operand, ffeinfo_new_any ()); + } + else + { + e->u.operand = ffebld_new_symter (s, + ffesymbol_generic (s), + ffesymbol_specific (s), + ffesymbol_implementation (s)); + ffebld_set_info (e->u.operand, ffesymbol_info (s)); + } + ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */ + ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0]; + switch (paren_type) + { + case FFEEXPR_parentypeSUBROUTINE_: + ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); + return + (ffelexHandler) + ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextACTUALARG_, + ffeexpr_token_arguments_); + + case FFEEXPR_parentypeARRAY_: + ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); + ffeexpr_stack_->bound_list = ffesymbol_dims (s); + ffeexpr_stack_->rank = 0; + ffeexpr_stack_->constant = TRUE; + ffeexpr_stack_->immediate = TRUE; + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextDATAIMPDOITEM_: + return + (ffelexHandler) + ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextDATAIMPDOINDEX_, + ffeexpr_token_elements_); + + case FFEEXPR_contextEQUIVALENCE: + return + (ffelexHandler) + ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextEQVINDEX_, + ffeexpr_token_elements_); + + default: + return + (ffelexHandler) + ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextINDEX_, + ffeexpr_token_elements_); + } + + case FFEEXPR_parentypeSUBSTRING_: + e->u.operand = ffeexpr_collapse_symter (e->u.operand, + ffeexpr_tokens_[0]); + return + (ffelexHandler) + ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextINDEX_, + ffeexpr_token_substring_); + + case FFEEXPR_parentypeEQUIVALENCE_: + ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); + ffeexpr_stack_->bound_list = ffesymbol_dims (s); + ffeexpr_stack_->rank = 0; + ffeexpr_stack_->constant = TRUE; + ffeexpr_stack_->immediate = TRUE; + return + (ffelexHandler) + ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextEQVINDEX_, + ffeexpr_token_equivalence_); + + case FFEEXPR_parentypeFUNCTION_: /* Invalid case. */ + case FFEEXPR_parentypeFUNSUBSTR_: /* Invalid case. */ + ffesymbol_error (s, ffeexpr_tokens_[0]); + /* Fall through. */ + case FFEEXPR_parentypeANY_: + e->u.operand = ffebld_new_any (); + ffebld_set_info (e->u.operand, ffeinfo_new_any ()); + return + (ffelexHandler) + ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextACTUALARG_, + ffeexpr_token_anything_); + + default: + assert ("bad paren type" == NULL); + break; + } + + case FFELEX_typeEQUALS: /* As in "VAR=". */ + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextIMPDOITEM_: /* within + "(,VAR=start,end[,incr])". */ + case FFEEXPR_contextIMPDOITEMDF_: + ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_; + break; + + case FFEEXPR_contextDATAIMPDOITEM_: + ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_; + break; + + default: + break; + } + break; + +#if 0 + case FFELEX_typePERIOD: + case FFELEX_typePERCENT: + assert ("FOO%, FOO. not yet supported!~~" == NULL); + break; +#endif + + default: + break; + } + +just_name: /* :::::::::::::::::::: */ + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + e->token = ffeexpr_tokens_[0]; + s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], + (ffeexpr_stack_->context + == FFEEXPR_contextSUBROUTINEREF)); + + switch (ffesymbol_where (s)) + { + case FFEINFO_whereCONSTANT: + if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER) + || (ffesymbol_kind (s) != FFEINFO_kindENTITY)) + ffesymbol_error (s, ffeexpr_tokens_[0]); + break; + + case FFEINFO_whereIMMEDIATE: + if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_) + && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_)) + ffesymbol_error (s, ffeexpr_tokens_[0]); + break; + + case FFEINFO_whereLOCAL: + if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF) + ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recurse!. */ + break; + + case FFEINFO_whereINTRINSIC: + if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF) + ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */ + break; + + default: + break; + } + + if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY) + { + expr = ffebld_new_any (); + info = ffeinfo_new_any (); + ffebld_set_info (expr, info); + } + else + { + expr = ffebld_new_symter (s, + ffesymbol_generic (s), + ffesymbol_specific (s), + ffesymbol_implementation (s)); + info = ffesymbol_info (s); + ffebld_set_info (expr, info); + if (ffesymbol_is_doiter (s)) + { + ffebad_start (FFEBAD_DOITER); + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), + ffelex_token_where_column (ffeexpr_tokens_[0])); + ffest_ffebad_here_doiter (1, s); + ffebad_string (ffesymbol_text (s)); + ffebad_finish (); + } + expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]); + } + + if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF) + { + if (ffebld_op (expr) == FFEBLD_opANY) + { + expr = ffebld_new_any (); + ffebld_set_info (expr, ffeinfo_new_any ()); + } + else + { + expr = ffebld_new_subrref (expr, NULL); /* No argument list. */ + if (ffesymbol_generic (s) != FFEINTRIN_genNONE) + ffeintrin_fulfill_generic (&expr, &info, e->token); + else if (ffesymbol_specific (s) != FFEINTRIN_specNONE) + ffeintrin_fulfill_specific (&expr, &info, NULL, e->token); + else + ffeexpr_fulfill_call_ (&expr, e->token); + + if (ffebld_op (expr) != FFEBLD_opANY) + ffebld_set_info (expr, + ffeinfo_new (ffeinfo_basictype (info), + ffeinfo_kindtype (info), + 0, + FFEINFO_kindENTITY, + FFEINFO_whereFLEETING, + ffeinfo_size (info))); + else + ffebld_set_info (expr, ffeinfo_new_any ()); + } + } + + e->u.operand = expr; + ffeexpr_exprstack_push_operand_ (e); + return (ffelexHandler) ffeexpr_finished_ (t); +} + +/* ffeexpr_token_name_arg_ -- Rhs NAME + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Handle first token in an actual-arg (or possible actual-arg) context + being a NAME, and use second token to refine the context. */ + +static ffelexHandler +ffeexpr_token_name_arg_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + case FFELEX_typeCOMMA: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_; + break; + + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_; + break; + + default: + break; + } + break; + + default: + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_; + break; + + case FFEEXPR_contextINDEXORACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_; + break; + + case FFEEXPR_contextSFUNCDEFACTUALARG_: + ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_; + break; + + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + ffeexpr_stack_->context + = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_; + break; + + default: + assert ("bad context in _name_arg_" == NULL); + break; + } + break; + } + + return (ffelexHandler) ffeexpr_token_name_rhs_ (t); +} + +/* ffeexpr_token_name_rhs_ -- Rhs NAME + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Handle a name followed by open-paren, apostrophe (O'octal-const', + Z'hex-const', or X'hex-const'), period (RECORD.MEMBER). + + 26-Nov-91 JCB 1.2 + When followed by apostrophe or quote, set lex hexnum flag on so + [0-9] as first char of next token seen as starting a potentially + hex number (NAME). + 04-Oct-91 JCB 1.1 + In case of intrinsic, decorate its SYMTER with the type info for + the specific intrinsic. */ + +static ffelexHandler +ffeexpr_token_name_rhs_ (ffelexToken t) +{ + ffeexprExpr_ e; + ffeexprParenType_ paren_type; + ffesymbol s; + bool sfdef; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeQUOTE: + case FFELEX_typeAPOSTROPHE: + ffeexpr_tokens_[1] = ffelex_token_use (t); + ffelex_set_hexnum (TRUE); + return (ffelexHandler) ffeexpr_token_name_apos_; + + case FFELEX_typeOPEN_PAREN: + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + e->token = ffelex_token_use (ffeexpr_tokens_[0]); + s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE, + &paren_type); + if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY) + e->u.operand = ffebld_new_any (); + else + e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s), + ffesymbol_specific (s), + ffesymbol_implementation (s)); + ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */ + ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0]; + switch (ffeexpr_context_outer_ (ffeexpr_stack_)) + { + case FFEEXPR_contextSFUNCDEF: + case FFEEXPR_contextSFUNCDEFINDEX_: + case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: + sfdef = TRUE; + break; + + case FFEEXPR_contextSFUNCDEFACTUALARG_: + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + assert ("weird context!" == NULL); + sfdef = FALSE; + break; + + default: + sfdef = FALSE; + break; + } + switch (paren_type) + { + case FFEEXPR_parentypeFUNCTION_: + ffebld_set_info (e->u.operand, ffesymbol_info (s)); + ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); + if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) + { /* A statement function. */ + ffeexpr_stack_->num_args + = ffebld_list_length + (ffeexpr_stack_->next_dummy + = ffesymbol_dummyargs (s)); + ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */ + } + else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC) + && !ffe_is_pedantic_not_90 () + && ((ffesymbol_implementation (s) + == FFEINTRIN_impICHAR) + || (ffesymbol_implementation (s) + == FFEINTRIN_impIACHAR) + || (ffesymbol_implementation (s) + == FFEINTRIN_impLEN))) + { /* Allow arbitrary concatenations. */ + return + (ffelexHandler) + ffeexpr_rhs (ffeexpr_stack_->pool, + sfdef + ? FFEEXPR_contextSFUNCDEF + : FFEEXPR_contextLET, + ffeexpr_token_arguments_); + } + return + (ffelexHandler) + ffeexpr_rhs (ffeexpr_stack_->pool, + sfdef + ? FFEEXPR_contextSFUNCDEFACTUALARG_ + : FFEEXPR_contextACTUALARG_, + ffeexpr_token_arguments_); + + case FFEEXPR_parentypeARRAY_: + ffebld_set_info (e->u.operand, + ffesymbol_info (ffebld_symter (e->u.operand))); + ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); + ffeexpr_stack_->bound_list = ffesymbol_dims (s); + ffeexpr_stack_->rank = 0; + ffeexpr_stack_->constant = TRUE; + ffeexpr_stack_->immediate = TRUE; + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + sfdef + ? FFEEXPR_contextSFUNCDEFINDEX_ + : FFEEXPR_contextINDEX_, + ffeexpr_token_elements_); + + case FFEEXPR_parentypeSUBSTRING_: + ffebld_set_info (e->u.operand, + ffesymbol_info (ffebld_symter (e->u.operand))); + e->u.operand = ffeexpr_collapse_symter (e->u.operand, + ffeexpr_tokens_[0]); + return + (ffelexHandler) + ffeexpr_rhs (ffeexpr_stack_->pool, + sfdef + ? FFEEXPR_contextSFUNCDEFINDEX_ + : FFEEXPR_contextINDEX_, + ffeexpr_token_substring_); + + case FFEEXPR_parentypeFUNSUBSTR_: + return + (ffelexHandler) + ffeexpr_rhs (ffeexpr_stack_->pool, + sfdef + ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_ + : FFEEXPR_contextINDEXORACTUALARG_, + ffeexpr_token_funsubstr_); + + case FFEEXPR_parentypeANY_: + ffebld_set_info (e->u.operand, ffesymbol_info (s)); + return + (ffelexHandler) + ffeexpr_rhs (ffeexpr_stack_->pool, + sfdef + ? FFEEXPR_contextSFUNCDEFACTUALARG_ + : FFEEXPR_contextACTUALARG_, + ffeexpr_token_anything_); + + default: + assert ("bad paren type" == NULL); + break; + } + + case FFELEX_typeEQUALS: /* As in "VAR=". */ + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */ + case FFEEXPR_contextIMPDOITEMDF_: + ffeexpr_stack_->is_rhs = FALSE; /* Really an lhs construct. */ + ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_; + break; + + default: + break; + } + break; + +#if 0 + case FFELEX_typePERIOD: + case FFELEX_typePERCENT: + ~~Support these two someday, though not required + assert ("FOO%, FOO. not yet supported!~~" == NULL); + break; +#endif + + default: + break; + } + + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextINDEXORACTUALARG_: + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + assert ("strange context" == NULL); + break; + + default: + break; + } + + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + e->token = ffeexpr_tokens_[0]; + s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE); + if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY) + { + e->u.operand = ffebld_new_any (); + ffebld_set_info (e->u.operand, ffeinfo_new_any ()); + } + else + { + e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE, + ffesymbol_specific (s), + ffesymbol_implementation (s)); + if (ffesymbol_specific (s) == FFEINTRIN_specNONE) + ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s))); + else + { /* Decorate the SYMTER with the actual type + of the intrinsic. */ + ffebld_set_info (e->u.operand, ffeinfo_new + (ffeintrin_basictype (ffesymbol_specific (s)), + ffeintrin_kindtype (ffesymbol_specific (s)), + 0, + ffesymbol_kind (s), + ffesymbol_where (s), + FFETARGET_charactersizeNONE)); + } + if (ffesymbol_is_doiter (s)) + ffebld_symter_set_is_doiter (e->u.operand, TRUE); + e->u.operand = ffeexpr_collapse_symter (e->u.operand, + ffeexpr_tokens_[0]); + } + ffeexpr_exprstack_push_operand_ (e); + return (ffelexHandler) ffeexpr_token_binary_ (t); +} + +/* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Expecting a NAME token, analyze the previous NAME token to see what kind, + if any, typeless constant we've got. + + 01-Sep-90 JCB 1.1 + Expect a NAME instead of CHARACTER in this situation. */ + +static ffelexHandler +ffeexpr_token_name_apos_ (ffelexToken t) +{ + ffeexprExpr_ e; + + ffelex_set_hexnum (FALSE); + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffeexpr_tokens_[2] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_name_apos_name_; + + default: + break; + } + + if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER)) + { + ffebad_string (ffelex_token_text (ffeexpr_tokens_[0])); + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), + ffelex_token_where_column (ffeexpr_tokens_[0])); + ffebad_here (1, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_finish (); + } + + ffelex_token_kill (ffeexpr_tokens_[1]); + + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + e->u.operand = ffebld_new_any (); + ffebld_set_info (e->u.operand, ffeinfo_new_any ()); + e->token = ffeexpr_tokens_[0]; + ffeexpr_exprstack_push_operand_ (e); + + return (ffelexHandler) ffeexpr_token_binary_ (t); +} + +/* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Expecting an APOSTROPHE token, analyze the previous NAME token to see + what kind, if any, typeless constant we've got. */ + +static ffelexHandler +ffeexpr_token_name_apos_name_ (ffelexToken t) +{ + ffeexprExpr_ e; + char c; + + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + e->token = ffeexpr_tokens_[0]; + + if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1])) + && (ffelex_token_length (ffeexpr_tokens_[0]) == 1) + && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]), + 'B', 'b') + || ffesrc_char_match_init (c, 'O', 'o') + || ffesrc_char_match_init (c, 'X', 'x') + || ffesrc_char_match_init (c, 'Z', 'z'))) + { + ffetargetCharacterSize size; + + if (!ffe_is_typeless_boz ()) { + + switch (c) + { + case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch): + e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary + (ffeexpr_tokens_[2])); + break; + + case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch): + e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal + (ffeexpr_tokens_[2])); + break; + + case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch): + e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex + (ffeexpr_tokens_[2])); + break; + + case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch): + e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex + (ffeexpr_tokens_[2])); + break; + + default: + no_imatch: /* :::::::::::::::::::: */ + assert ("not BOXZ!" == NULL); + abort (); + } + + ffebld_set_info (e->u.operand, + ffeinfo_new (FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, + FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + ffeexpr_exprstack_push_operand_ (e); + ffelex_token_kill (ffeexpr_tokens_[1]); + ffelex_token_kill (ffeexpr_tokens_[2]); + return (ffelexHandler) ffeexpr_token_binary_; + } + + switch (c) + { + case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match): + e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm + (ffeexpr_tokens_[2])); + size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]); + break; + + case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match): + e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om + (ffeexpr_tokens_[2])); + size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]); + break; + + case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match): + e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm + (ffeexpr_tokens_[2])); + size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]); + break; + + case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match): + e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm + (ffeexpr_tokens_[2])); + size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]); + break; + + default: + no_match: /* :::::::::::::::::::: */ + assert ("not BOXZ!" == NULL); + e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm + (ffeexpr_tokens_[2])); + size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]); + break; + } + ffebld_set_info (e->u.operand, + ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE, + 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size)); + ffeexpr_exprstack_push_operand_ (e); + ffelex_token_kill (ffeexpr_tokens_[1]); + ffelex_token_kill (ffeexpr_tokens_[2]); + return (ffelexHandler) ffeexpr_token_binary_; + } + + if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER)) + { + ffebad_string (ffelex_token_text (ffeexpr_tokens_[0])); + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), + ffelex_token_where_column (ffeexpr_tokens_[0])); + ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + ffelex_token_kill (ffeexpr_tokens_[1]); + ffelex_token_kill (ffeexpr_tokens_[2]); + + e->type = FFEEXPR_exprtypeOPERAND_; + e->u.operand = ffebld_new_any (); + ffebld_set_info (e->u.operand, ffeinfo_new_any ()); + e->token = ffeexpr_tokens_[0]; + ffeexpr_exprstack_push_operand_ (e); + + switch (ffelex_token_type (t)) + { + case FFELEX_typeAPOSTROPHE: + case FFELEX_typeQUOTE: + return (ffelexHandler) ffeexpr_token_binary_; + + default: + return (ffelexHandler) ffeexpr_token_binary_ (t); + } +} + +/* ffeexpr_token_percent_ -- Rhs PERCENT + + Handle a percent sign possibly followed by "LOC". If followed instead + by "VAL", "REF", or "DESCR", issue an error message and substitute + "LOC". If followed by something else, treat the percent sign as a + spurious incorrect token and reprocess the token via _rhs_. */ + +static ffelexHandler +ffeexpr_token_percent_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + case FFELEX_typeNAMES: + ffeexpr_stack_->percent = ffeexpr_percent_ (t); + ffeexpr_tokens_[1] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_token_percent_name_; + + default: + if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), + ffelex_token_where_column (ffeexpr_tokens_[0])); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), + ffelex_token_where_column (ffeexpr_stack_->first_token)); + ffebad_finish (); + } + ffelex_token_kill (ffeexpr_tokens_[0]); + return (ffelexHandler) ffeexpr_token_rhs_ (t); + } +} + +/* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME + + Make sure the token is OPEN_PAREN and prepare for the one-item list of + LHS expressions. Else display an error message. */ + +static ffelexHandler +ffeexpr_token_percent_name_ (ffelexToken t) +{ + ffelexHandler nexthandler; + + if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN) + { + if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), + ffelex_token_where_column (ffeexpr_tokens_[0])); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token), + ffelex_token_where_column (ffeexpr_stack_->first_token)); + ffebad_finish (); + } + ffelex_token_kill (ffeexpr_tokens_[0]); + nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]); + ffelex_token_kill (ffeexpr_tokens_[1]); + return (ffelexHandler) (*nexthandler) (t); + } + + switch (ffeexpr_stack_->percent) + { + default: + if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]), + ffelex_token_where_column (ffeexpr_tokens_[0])); + ffebad_string (ffelex_token_text (ffeexpr_tokens_[1])); + ffebad_finish (); + } + ffeexpr_stack_->percent = FFEEXPR_percentLOC_; + /* Fall through. */ + case FFEEXPR_percentLOC_: + ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0]; + ffelex_token_kill (ffeexpr_tokens_[1]); + ffeexpr_stack_->tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextLOC_, + ffeexpr_cb_end_loc_); + } +} + +/* ffeexpr_make_float_const_ -- Make a floating-point constant + + See prototype. + + Pass 'E', 'D', or 'Q' for exponent letter. */ + +static void +ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer, + ffelexToken decimal, ffelexToken fraction, + ffelexToken exponent, ffelexToken exponent_sign, + ffelexToken exponent_digits) +{ + ffeexprExpr_ e; + + e = ffeexpr_expr_new_ (); + e->type = FFEEXPR_exprtypeOPERAND_; + if (integer != NULL) + e->token = ffelex_token_use (integer); + else + { + assert (decimal != NULL); + e->token = ffelex_token_use (decimal); + } + + switch (exp_letter) + { +#if !FFETARGET_okREALQUAD + case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match): + if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED)) + { + ffebad_here (0, ffelex_token_where_line (e->token), + ffelex_token_where_column (e->token)); + ffebad_finish (); + } + goto match_d; /* The FFESRC_CASE_* macros don't + allow fall-through! */ +#endif + + case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match): + e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble + (integer, decimal, fraction, exponent, exponent_sign, exponent_digits)); + ffebld_set_info (e->u.operand, + ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE, + 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); + break; + + case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match): + e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault + (integer, decimal, fraction, exponent, exponent_sign, exponent_digits)); + ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL, + FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); + break; + +#if FFETARGET_okREALQUAD + case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match): + e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad + (integer, decimal, fraction, exponent, exponent_sign, exponent_digits)); + ffebld_set_info (e->u.operand, + ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD, + 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE)); + break; +#endif + + default: + no_match: /* :::::::::::::::::::: */ + assert ("Lost the exponent letter!" == NULL); + } + + ffeexpr_exprstack_push_operand_ (e); +} + +/* Just like ffesymbol_declare_local, except performs any implicit info + assignment necessary. */ + +static ffesymbol +ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin) +{ + ffesymbol s; + ffeinfoKind k; + bool bad; + + s = ffesymbol_declare_local (t, maybe_intrin); + + switch (ffeexpr_context_outer_ (ffeexpr_stack_)) + /* Special-case these since they can involve a different concept + of "state" (in the stmtfunc name space). */ + { + case FFEEXPR_contextDATAIMPDOINDEX_: + case FFEEXPR_contextDATAIMPDOCTRL_: + if (ffeexpr_context_outer_ (ffeexpr_stack_) + == FFEEXPR_contextDATAIMPDOINDEX_) + s = ffeexpr_sym_impdoitem_ (s, t); + else + if (ffeexpr_stack_->is_rhs) + s = ffeexpr_sym_impdoitem_ (s, t); + else + s = ffeexpr_sym_lhs_impdoctrl_ (s, t); + bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY) + || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT) + && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE)); + if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY)) + ffesymbol_error (s, t); + return s; + + default: + break; + } + + switch ((ffesymbol_sfdummyparent (s) == NULL) + ? ffesymbol_state (s) + : FFESYMBOL_stateUNDERSTOOD) + { + case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr + context. */ + if (!ffest_seen_first_exec ()) + goto seen; /* :::::::::::::::::::: */ + /* Fall through. */ + case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */ + switch (ffeexpr_context_outer_ (ffeexpr_stack_)) + { + case FFEEXPR_contextSUBROUTINEREF: + s = ffeexpr_sym_lhs_call_ (s, t); + break; + + case FFEEXPR_contextFILEEXTFUNC: + s = ffeexpr_sym_lhs_extfunc_ (s, t); + break; + + case FFEEXPR_contextSFUNCDEFACTUALARG_: + s = ffecom_sym_exec_transition (s); + if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) + goto understood; /* :::::::::::::::::::: */ + /* Fall through. */ + case FFEEXPR_contextACTUALARG_: + s = ffeexpr_sym_rhs_actualarg_ (s, t); + break; + + case FFEEXPR_contextDATA: + if (ffeexpr_stack_->is_rhs) + s = ffeexpr_sym_rhs_let_ (s, t); + else + s = ffeexpr_sym_lhs_data_ (s, t); + break; + + case FFEEXPR_contextDATAIMPDOITEM_: + s = ffeexpr_sym_lhs_data_ (s, t); + break; + + case FFEEXPR_contextSFUNCDEF: + case FFEEXPR_contextSFUNCDEFINDEX_: + case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: + s = ffecom_sym_exec_transition (s); + if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) + goto understood; /* :::::::::::::::::::: */ + /* Fall through. */ + case FFEEXPR_contextLET: + case FFEEXPR_contextPAREN_: + case FFEEXPR_contextACTUALARGEXPR_: + case FFEEXPR_contextINDEXORACTUALARGEXPR_: + case FFEEXPR_contextASSIGN: + case FFEEXPR_contextIOLIST: + case FFEEXPR_contextIOLISTDF: + case FFEEXPR_contextDO: + case FFEEXPR_contextDOWHILE: + case FFEEXPR_contextAGOTO: + case FFEEXPR_contextCGOTO: + case FFEEXPR_contextIF: + case FFEEXPR_contextARITHIF: + case FFEEXPR_contextFORMAT: + case FFEEXPR_contextSTOP: + case FFEEXPR_contextRETURN: + case FFEEXPR_contextSELECTCASE: + case FFEEXPR_contextCASE: + case FFEEXPR_contextFILEASSOC: + case FFEEXPR_contextFILEINT: + case FFEEXPR_contextFILEDFINT: + case FFEEXPR_contextFILELOG: + case FFEEXPR_contextFILENUM: + case FFEEXPR_contextFILENUMAMBIG: + case FFEEXPR_contextFILECHAR: + case FFEEXPR_contextFILENUMCHAR: + case FFEEXPR_contextFILEDFCHAR: + case FFEEXPR_contextFILEKEY: + case FFEEXPR_contextFILEUNIT: + case FFEEXPR_contextFILEUNIT_DF: + case FFEEXPR_contextFILEUNITAMBIG: + case FFEEXPR_contextFILEFORMAT: + case FFEEXPR_contextFILENAMELIST: + case FFEEXPR_contextFILEVXTCODE: + case FFEEXPR_contextINDEX_: + case FFEEXPR_contextIMPDOITEM_: + case FFEEXPR_contextIMPDOITEMDF_: + case FFEEXPR_contextIMPDOCTRL_: + case FFEEXPR_contextLOC_: + if (ffeexpr_stack_->is_rhs) + s = ffeexpr_sym_rhs_let_ (s, t); + else + s = ffeexpr_sym_lhs_let_ (s, t); + break; + + case FFEEXPR_contextCHARACTERSIZE: + case FFEEXPR_contextEQUIVALENCE: + case FFEEXPR_contextINCLUDE: + case FFEEXPR_contextPARAMETER: + case FFEEXPR_contextDIMLIST: + case FFEEXPR_contextDIMLISTCOMMON: + case FFEEXPR_contextKINDTYPE: + case FFEEXPR_contextINITVAL: + case FFEEXPR_contextEQVINDEX_: + break; /* Will turn into errors below. */ + + default: + ffesymbol_error (s, t); + break; + } + /* Fall through. */ + case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */ + understood: /* :::::::::::::::::::: */ + k = ffesymbol_kind (s); + switch (ffeexpr_context_outer_ (ffeexpr_stack_)) + { + case FFEEXPR_contextSUBROUTINEREF: + bad = ((k != FFEINFO_kindSUBROUTINE) + && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC) + || (k != FFEINFO_kindNONE))); + break; + + case FFEEXPR_contextFILEEXTFUNC: + bad = (k != FFEINFO_kindFUNCTION) + || (ffesymbol_where (s) != FFEINFO_whereGLOBAL); + break; + + case FFEEXPR_contextSFUNCDEFACTUALARG_: + case FFEEXPR_contextACTUALARG_: + switch (k) + { + case FFEINFO_kindENTITY: + bad = FALSE; + break; + + case FFEINFO_kindFUNCTION: + case FFEINFO_kindSUBROUTINE: + bad + = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL) + && (ffesymbol_where (s) != FFEINFO_whereDUMMY) + && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC) + || !ffeintrin_is_actualarg (ffesymbol_specific (s)))); + break; + + case FFEINFO_kindNONE: + if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC) + { + bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s))); + break; + } + + /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY, + and in the former case, attrsTYPE is set, so we + see this as an error as we should, since CHAR*(*) + cannot be actually referenced in a main/block data + program unit. */ + + if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsTYPE)) + == FFESYMBOL_attrsEXTERNAL) + bad = FALSE; + else + bad = TRUE; + break; + + default: + bad = TRUE; + break; + } + break; + + case FFEEXPR_contextDATA: + if (ffeexpr_stack_->is_rhs) + bad = (k != FFEINFO_kindENTITY) + || (ffesymbol_where (s) != FFEINFO_whereCONSTANT); + else + bad = (k != FFEINFO_kindENTITY) + || ((ffesymbol_where (s) != FFEINFO_whereNONE) + && (ffesymbol_where (s) != FFEINFO_whereLOCAL) + && (ffesymbol_where (s) != FFEINFO_whereCOMMON)); + break; + + case FFEEXPR_contextDATAIMPDOITEM_: + bad = TRUE; /* Unadorned item never valid. */ + break; + + case FFEEXPR_contextSFUNCDEF: + case FFEEXPR_contextSFUNCDEFINDEX_: + case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: + case FFEEXPR_contextLET: + case FFEEXPR_contextPAREN_: + case FFEEXPR_contextACTUALARGEXPR_: + case FFEEXPR_contextINDEXORACTUALARGEXPR_: + case FFEEXPR_contextASSIGN: + case FFEEXPR_contextIOLIST: + case FFEEXPR_contextIOLISTDF: + case FFEEXPR_contextDO: + case FFEEXPR_contextDOWHILE: + case FFEEXPR_contextAGOTO: + case FFEEXPR_contextCGOTO: + case FFEEXPR_contextIF: + case FFEEXPR_contextARITHIF: + case FFEEXPR_contextFORMAT: + case FFEEXPR_contextSTOP: + case FFEEXPR_contextRETURN: + case FFEEXPR_contextSELECTCASE: + case FFEEXPR_contextCASE: + case FFEEXPR_contextFILEASSOC: + case FFEEXPR_contextFILEINT: + case FFEEXPR_contextFILEDFINT: + case FFEEXPR_contextFILELOG: + case FFEEXPR_contextFILENUM: + case FFEEXPR_contextFILENUMAMBIG: + case FFEEXPR_contextFILECHAR: + case FFEEXPR_contextFILENUMCHAR: + case FFEEXPR_contextFILEDFCHAR: + case FFEEXPR_contextFILEKEY: + case FFEEXPR_contextFILEUNIT: + case FFEEXPR_contextFILEUNIT_DF: + case FFEEXPR_contextFILEUNITAMBIG: + case FFEEXPR_contextFILEFORMAT: + case FFEEXPR_contextFILENAMELIST: + case FFEEXPR_contextFILEVXTCODE: + case FFEEXPR_contextINDEX_: + case FFEEXPR_contextIMPDOITEM_: + case FFEEXPR_contextIMPDOITEMDF_: + case FFEEXPR_contextIMPDOCTRL_: + case FFEEXPR_contextLOC_: + bad = (k != FFEINFO_kindENTITY); /* This catches "SUBROUTINE + X(A);EXTERNAL A;CALL + Y(A);B=A", for example. */ + break; + + case FFEEXPR_contextCHARACTERSIZE: + case FFEEXPR_contextEQUIVALENCE: + case FFEEXPR_contextPARAMETER: + case FFEEXPR_contextDIMLIST: + case FFEEXPR_contextDIMLISTCOMMON: + case FFEEXPR_contextKINDTYPE: + case FFEEXPR_contextINITVAL: + case FFEEXPR_contextEQVINDEX_: + bad = (k != FFEINFO_kindENTITY) + || (ffesymbol_where (s) != FFEINFO_whereCONSTANT); + break; + + case FFEEXPR_contextINCLUDE: + bad = TRUE; + break; + + default: + bad = TRUE; + break; + } + if (bad && (k != FFEINFO_kindANY)) + ffesymbol_error (s, t); + return s; + + case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */ + seen: /* :::::::::::::::::::: */ + switch (ffeexpr_context_outer_ (ffeexpr_stack_)) + { + case FFEEXPR_contextPARAMETER: + if (ffeexpr_stack_->is_rhs) + ffesymbol_error (s, t); + else + s = ffeexpr_sym_lhs_parameter_ (s, t); + break; + + case FFEEXPR_contextDATA: + s = ffecom_sym_exec_transition (s); + if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) + goto understood; /* :::::::::::::::::::: */ + if (ffeexpr_stack_->is_rhs) + ffesymbol_error (s, t); + else + s = ffeexpr_sym_lhs_data_ (s, t); + goto understood; /* :::::::::::::::::::: */ + + case FFEEXPR_contextDATAIMPDOITEM_: + s = ffecom_sym_exec_transition (s); + if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) + goto understood; /* :::::::::::::::::::: */ + s = ffeexpr_sym_lhs_data_ (s, t); + goto understood; /* :::::::::::::::::::: */ + + case FFEEXPR_contextEQUIVALENCE: + s = ffeexpr_sym_lhs_equivalence_ (s, t); + break; + + case FFEEXPR_contextDIMLIST: + s = ffeexpr_sym_rhs_dimlist_ (s, t); + break; + + case FFEEXPR_contextCHARACTERSIZE: + case FFEEXPR_contextKINDTYPE: + case FFEEXPR_contextDIMLISTCOMMON: + case FFEEXPR_contextINITVAL: + case FFEEXPR_contextEQVINDEX_: + ffesymbol_error (s, t); + break; + + case FFEEXPR_contextINCLUDE: + ffesymbol_error (s, t); + break; + + case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */ + case FFEEXPR_contextSFUNCDEFACTUALARG_: + s = ffecom_sym_exec_transition (s); + if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) + goto understood; /* :::::::::::::::::::: */ + s = ffeexpr_sym_rhs_actualarg_ (s, t); + goto understood; /* :::::::::::::::::::: */ + + case FFEEXPR_contextINDEX_: + case FFEEXPR_contextACTUALARGEXPR_: + case FFEEXPR_contextINDEXORACTUALARGEXPR_: + case FFEEXPR_contextSFUNCDEF: + case FFEEXPR_contextSFUNCDEFINDEX_: + case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: + assert (ffeexpr_stack_->is_rhs); + s = ffecom_sym_exec_transition (s); + if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) + goto understood; /* :::::::::::::::::::: */ + s = ffeexpr_sym_rhs_let_ (s, t); + goto understood; /* :::::::::::::::::::: */ + + default: + ffesymbol_error (s, t); + break; + } + return s; + + default: + assert ("bad symbol state" == NULL); + return NULL; + break; + } +} + +/* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH). + Could be found via the "statement-function" name space (in which case + it should become an iterator) or the local name space (in which case + it should be either a named constant, or a variable that will have an + sfunc name space sibling that should become an iterator). */ + +static ffesymbol +ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t) +{ + ffesymbol s; + ffesymbolAttrs sa; + ffesymbolAttrs na; + ffesymbolState ss; + ffesymbolState ns; + ffeinfoKind kind; + ffeinfoWhere where; + + ss = ffesymbol_state (sp); + + if (ffesymbol_sfdummyparent (sp) != NULL) + { /* Have symbol in sfunc name space. */ + switch (ss) + { + case FFESYMBOL_stateNONE: /* Used as iterator already. */ + if (ffeexpr_level_ < ffesymbol_maxentrynum (sp)) + ffesymbol_error (sp, t); /* Can't use dead iterator. */ + else + { /* Can use dead iterator because we're at at + least an innermore (higher-numbered) level + than the iterator's outermost + (lowest-numbered) level. */ + ffesymbol_signal_change (sp); + ffesymbol_set_state (sp, FFESYMBOL_stateSEEN); + ffesymbol_set_maxentrynum (sp, ffeexpr_level_); + ffesymbol_signal_unreported (sp); + } + break; + + case FFESYMBOL_stateSEEN: /* Seen already in this or other + implied-DO. Set symbol level + number to outermost value, as that + tells us we can see it as iterator + at that level at the innermost. */ + if (ffeexpr_level_ < ffesymbol_maxentrynum (sp)) + { + ffesymbol_signal_change (sp); + ffesymbol_set_maxentrynum (sp, ffeexpr_level_); + ffesymbol_signal_unreported (sp); + } + break; + + case FFESYMBOL_stateUNCERTAIN: /* Iterator. */ + assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp)); + ffesymbol_error (sp, t); /* (,,,I=I,10). */ + break; + + case FFESYMBOL_stateUNDERSTOOD: + break; /* ANY. */ + + default: + assert ("Foo Bar!!" == NULL); + break; + } + + return sp; + } + + /* Got symbol in local name space, so we haven't seen it in impdo yet. + First, if it is brand-new and we're in executable statements, set the + attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD. + Second, if it is now a constant (PARAMETER), then just return it, it + can't be an implied-do iterator. If it is understood, complain if it is + not a valid variable, but make the inner name space iterator anyway and + return that. If it is not understood, improve understanding of the + symbol accordingly, complain accordingly, in either case make the inner + name space iterator and return that. */ + + sa = ffesymbol_attrs (sp); + + if (ffesymbol_state_is_specable (ss) + && ffest_seen_first_exec ()) + { + assert (sa == FFESYMBOL_attrsetNONE); + ffesymbol_signal_change (sp); + ffesymbol_set_state (sp, FFESYMBOL_stateSEEN); + ffesymbol_resolve_intrin (sp); + if (ffeimplic_establish_symbol (sp)) + ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG); + else + ffesymbol_error (sp, t); + + /* After the exec transition, the state will either be UNCERTAIN (could + be a dummy or local var) or UNDERSTOOD (local var, because this is a + PROGRAM/BLOCKDATA program unit). */ + + sp = ffecom_sym_exec_transition (sp); + sa = ffesymbol_attrs (sp); + ss = ffesymbol_state (sp); + } + + ns = ss; + kind = ffesymbol_kind (sp); + where = ffesymbol_where (sp); + + if (ss == FFESYMBOL_stateUNDERSTOOD) + { + if (kind != FFEINFO_kindENTITY) + ffesymbol_error (sp, t); + if (where == FFEINFO_whereCONSTANT) + return sp; + } + else + { + /* Enhance understanding of local symbol. This used to imply exec + transition, but that doesn't seem necessary, since the local symbol + doesn't actually get put into an ffebld tree here -- we just learn + more about it, just like when we see a local symbol's name in the + dummy-arg list of a statement function. */ + + if (ss != FFESYMBOL_stateUNCERTAIN) + { + /* Figure out what kind of object we've got based on previous + declarations of or references to the object. */ + + ns = FFESYMBOL_stateSEEN; + + if (sa & FFESYMBOL_attrsANY) + na = sa; + else if (!(sa & ~(FFESYMBOL_attrsADJUSTS + | FFESYMBOL_attrsANY + | FFESYMBOL_attrsCOMMON + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEQUIV + | FFESYMBOL_attrsINIT + | FFESYMBOL_attrsNAMELIST + | FFESYMBOL_attrsRESULT + | FFESYMBOL_attrsSAVE + | FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))) + na = sa | FFESYMBOL_attrsSFARG; + else + na = FFESYMBOL_attrsetNONE; + } + else + { /* stateUNCERTAIN. */ + na = sa | FFESYMBOL_attrsSFARG; + ns = FFESYMBOL_stateUNDERSTOOD; + + assert (!(sa & ~(FFESYMBOL_attrsACTUALARG + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))); + + if (sa & FFESYMBOL_attrsEXTERNAL) + { + assert (!(sa & ~(FFESYMBOL_attrsACTUALARG + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsTYPE))); + + na = FFESYMBOL_attrsetNONE; + } + else if (sa & FFESYMBOL_attrsDUMMY) + { + assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ + assert (!(sa & ~(FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsTYPE))); + + kind = FFEINFO_kindENTITY; + } + else if (sa & FFESYMBOL_attrsARRAY) + { + assert (!(sa & ~(FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsTYPE))); + + na = FFESYMBOL_attrsetNONE; + } + else if (sa & FFESYMBOL_attrsSFARG) + { + assert (!(sa & ~(FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))); + + ns = FFESYMBOL_stateUNCERTAIN; + } + else if (sa & FFESYMBOL_attrsTYPE) + { + assert (!(sa & (FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG))); /* Handled above. */ + assert (!(sa & ~(FFESYMBOL_attrsTYPE + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG))); + + kind = FFEINFO_kindENTITY; + + if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN)) + na = FFESYMBOL_attrsetNONE; + else if (ffest_is_entry_valid ()) + ns = FFESYMBOL_stateUNCERTAIN; /* Could be DUMMY or LOCAL. */ + else + where = FFEINFO_whereLOCAL; + } + else + na = FFESYMBOL_attrsetNONE; /* Error. */ + } + + /* Now see what we've got for a new object: NONE means a new error + cropped up; ANY means an old error to be ignored; otherwise, + everything's ok, update the object (symbol) and continue on. */ + + if (na == FFESYMBOL_attrsetNONE) + ffesymbol_error (sp, t); + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_signal_change (sp); /* May need to back up to previous + version. */ + if (!ffeimplic_establish_symbol (sp)) + ffesymbol_error (sp, t); + ffesymbol_set_info (sp, + ffeinfo_new (ffesymbol_basictype (sp), + ffesymbol_kindtype (sp), + ffesymbol_rank (sp), + kind, + where, + ffesymbol_size (sp))); + ffesymbol_set_attrs (sp, na); + ffesymbol_set_state (sp, ns); + ffesymbol_resolve_intrin (sp); + if (!ffesymbol_state_is_specable (ns)) + sp = ffecom_sym_learned (sp); + ffesymbol_signal_unreported (sp); /* For debugging purposes. */ + } + } + + /* Here we create the sfunc-name-space symbol representing what should + become an iterator in this name space at this or an outermore (lower- + numbered) expression level, else the implied-DO construct is in error. */ + + s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj; + also sets sfa_dummy_parent to + parent symbol. */ + assert (sp == ffesymbol_sfdummyparent (s)); + + ffesymbol_signal_change (s); + ffesymbol_set_state (s, FFESYMBOL_stateSEEN); + ffesymbol_set_maxentrynum (s, ffeexpr_level_); + ffesymbol_set_info (s, + ffeinfo_new (FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereIMMEDIATE, + FFETARGET_charactersizeNONE)); + ffesymbol_signal_unreported (s); + + if (((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER) + && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY)) + || ((ffesymbol_kindtype (sp) != FFEINFO_kindtypeINTEGERDEFAULT) + && (ffesymbol_kindtype (sp) != FFEINFO_kindtypeANY))) + ffesymbol_error (s, t); + + return s; +} + +/* Have FOO in CALL FOO. Local name space, executable context only. */ + +static ffesymbol +ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t) +{ + ffesymbolAttrs sa; + ffesymbolAttrs na; + ffeinfoKind kind; + ffeinfoWhere where; + ffeintrinGen gen; + ffeintrinSpec spec; + ffeintrinImp imp; + bool error = FALSE; + + assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) + || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); + + na = sa = ffesymbol_attrs (s); + + assert (!(sa & ~(FFESYMBOL_attrsACTUALARG + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))); + + kind = ffesymbol_kind (s); + where = ffesymbol_where (s); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + if (sa & FFESYMBOL_attrsEXTERNAL) + { + assert (!(sa & ~(FFESYMBOL_attrsACTUALARG + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsTYPE))); + + if (sa & FFESYMBOL_attrsTYPE) + error = TRUE; + else + /* Not TYPE. */ + { + kind = FFEINFO_kindSUBROUTINE; + + if (sa & FFESYMBOL_attrsDUMMY) + ; /* Not TYPE. */ + else if (sa & FFESYMBOL_attrsACTUALARG) + ; /* Not DUMMY or TYPE. */ + else /* Not ACTUALARG, DUMMY, or TYPE. */ + where = FFEINFO_whereGLOBAL; + } + } + else if (sa & FFESYMBOL_attrsDUMMY) + { + assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ + assert (!(sa & ~(FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsTYPE))); + + if (sa & FFESYMBOL_attrsTYPE) + error = TRUE; + else + kind = FFEINFO_kindSUBROUTINE; + } + else if (sa & FFESYMBOL_attrsARRAY) + { + assert (!(sa & ~(FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsTYPE))); + + error = TRUE; + } + else if (sa & FFESYMBOL_attrsSFARG) + { + assert (!(sa & ~(FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))); + + error = TRUE; + } + else if (sa & FFESYMBOL_attrsTYPE) + { + assert (!(sa & (FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG))); /* Handled above. */ + assert (!(sa & ~(FFESYMBOL_attrsTYPE + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG))); + + error = TRUE; + } + else if (sa == FFESYMBOL_attrsetNONE) + { + assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); + + if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE, + &gen, &spec, &imp)) + { + ffesymbol_signal_change (s); /* May need to back up to previous + version. */ + ffesymbol_set_generic (s, gen); + ffesymbol_set_specific (s, spec); + ffesymbol_set_implementation (s, imp); + ffesymbol_set_info (s, + ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, + 0, + FFEINFO_kindSUBROUTINE, + FFEINFO_whereINTRINSIC, + FFETARGET_charactersizeNONE)); + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_resolve_intrin (s); + ffesymbol_reference (s, t, FALSE); + s = ffecom_sym_learned (s); + ffesymbol_signal_unreported (s); /* For debugging purposes. */ + + return s; + } + + kind = FFEINFO_kindSUBROUTINE; + where = FFEINFO_whereGLOBAL; + } + else + error = TRUE; + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (error) + ffesymbol_error (s, t); + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_signal_change (s); /* May need to back up to previous + version. */ + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + ffesymbol_rank (s), + kind, /* SUBROUTINE. */ + where, /* GLOBAL or DUMMY. */ + ffesymbol_size (s))); + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_resolve_intrin (s); + ffesymbol_reference (s, t, FALSE); + s = ffecom_sym_learned (s); + ffesymbol_signal_unreported (s); /* For debugging purposes. */ + } + + return s; +} + +/* Have FOO in DATA FOO/.../. Local name space and executable context + only. (This will change in the future when DATA FOO may be followed + by COMMON FOO or even INTEGER FOO(10), etc.) */ + +static ffesymbol +ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t) +{ + ffesymbolAttrs sa; + ffesymbolAttrs na; + ffeinfoKind kind; + ffeinfoWhere where; + bool error = FALSE; + + assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) + || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); + + na = sa = ffesymbol_attrs (s); + + assert (!(sa & ~(FFESYMBOL_attrsACTUALARG + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))); + + kind = ffesymbol_kind (s); + where = ffesymbol_where (s); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + if (sa & FFESYMBOL_attrsEXTERNAL) + { + assert (!(sa & ~(FFESYMBOL_attrsACTUALARG + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsTYPE))); + + error = TRUE; + } + else if (sa & FFESYMBOL_attrsDUMMY) + { + assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ + assert (!(sa & ~(FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsTYPE))); + + error = TRUE; + } + else if (sa & FFESYMBOL_attrsARRAY) + { + assert (!(sa & ~(FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsTYPE))); + + if (sa & FFESYMBOL_attrsADJUSTABLE) + error = TRUE; + where = FFEINFO_whereLOCAL; + } + else if (sa & FFESYMBOL_attrsSFARG) + { + assert (!(sa & ~(FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))); + + where = FFEINFO_whereLOCAL; + } + else if (sa & FFESYMBOL_attrsTYPE) + { + assert (!(sa & (FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG))); /* Handled above. */ + assert (!(sa & ~(FFESYMBOL_attrsTYPE + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG))); + + if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN)) + error = TRUE; + else + { + kind = FFEINFO_kindENTITY; + where = FFEINFO_whereLOCAL; + } + } + else if (sa == FFESYMBOL_attrsetNONE) + { + assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); + kind = FFEINFO_kindENTITY; + where = FFEINFO_whereLOCAL; + } + else + error = TRUE; + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (error) + ffesymbol_error (s, t); + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_signal_change (s); /* May need to back up to previous + version. */ + if (!ffeimplic_establish_symbol (s)) + { + ffesymbol_error (s, t); + return s; + } + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + ffesymbol_rank (s), + kind, /* ENTITY. */ + where, /* LOCAL. */ + ffesymbol_size (s))); + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_resolve_intrin (s); + s = ffecom_sym_learned (s); + ffesymbol_signal_unreported (s); /* For debugging purposes. */ + } + + return s; +} + +/* Have FOO in EQUIVALENCE (...,FOO,...). Does not include + EQUIVALENCE (...,BAR(FOO),...). */ + +static ffesymbol +ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t) +{ + ffesymbolAttrs sa; + ffesymbolAttrs na; + ffeinfoKind kind; + ffeinfoWhere where; + + na = sa = ffesymbol_attrs (s); + kind = FFEINFO_kindENTITY; + where = ffesymbol_where (s); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + if (!(sa & ~(FFESYMBOL_attrsADJUSTS + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsCOMMON + | FFESYMBOL_attrsEQUIV + | FFESYMBOL_attrsINIT + | FFESYMBOL_attrsNAMELIST + | FFESYMBOL_attrsSAVE + | FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))) + na = sa | FFESYMBOL_attrsEQUIV; + else + na = FFESYMBOL_attrsetNONE; + + /* Don't know why we're bothering to set kind and where in this code, but + added the following to make it complete, in case it's really important. + Generally this is left up to symbol exec transition. */ + + if (where == FFEINFO_whereNONE) + { + if (na & (FFESYMBOL_attrsADJUSTS + | FFESYMBOL_attrsCOMMON)) + where = FFEINFO_whereCOMMON; + else if (na & FFESYMBOL_attrsSAVE) + where = FFEINFO_whereLOCAL; + } + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (na == FFESYMBOL_attrsetNONE) + ffesymbol_error (s, t); + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_signal_change (s); /* May need to back up to previous + version. */ + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + ffesymbol_rank (s), + kind, /* Always ENTITY. */ + where, /* NONE, COMMON, or LOCAL. */ + ffesymbol_size (s))); + ffesymbol_set_attrs (s, na); + ffesymbol_set_state (s, FFESYMBOL_stateSEEN); + ffesymbol_resolve_intrin (s); + ffesymbol_signal_unreported (s); /* For debugging purposes. */ + } + + return s; +} + +/* Have FOO in OPEN(...,USEROPEN=FOO,...). Executable context only. + + Note that I think this should be considered semantically similar to + doing CALL XYZ(FOO), in that it should be considered like an + ACTUALARG context. In particular, without EXTERNAL being specified, + it should not be allowed. */ + +static ffesymbol +ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t) +{ + ffesymbolAttrs sa; + ffesymbolAttrs na; + ffeinfoKind kind; + ffeinfoWhere where; + bool needs_type = FALSE; + bool error = FALSE; + + assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) + || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); + + na = sa = ffesymbol_attrs (s); + + assert (!(sa & ~(FFESYMBOL_attrsACTUALARG + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))); + + kind = ffesymbol_kind (s); + where = ffesymbol_where (s); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + if (sa & FFESYMBOL_attrsEXTERNAL) + { + assert (!(sa & ~(FFESYMBOL_attrsACTUALARG + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsTYPE))); + + if (sa & FFESYMBOL_attrsTYPE) + where = FFEINFO_whereGLOBAL; + else + /* Not TYPE. */ + { + kind = FFEINFO_kindFUNCTION; + needs_type = TRUE; + + if (sa & FFESYMBOL_attrsDUMMY) + ; /* Not TYPE. */ + else if (sa & FFESYMBOL_attrsACTUALARG) + ; /* Not DUMMY or TYPE. */ + else /* Not ACTUALARG, DUMMY, or TYPE. */ + where = FFEINFO_whereGLOBAL; + } + } + else if (sa & FFESYMBOL_attrsDUMMY) + { + assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ + assert (!(sa & ~(FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsTYPE))); + + kind = FFEINFO_kindFUNCTION; + if (!(sa & FFESYMBOL_attrsTYPE)) + needs_type = TRUE; + } + else if (sa & FFESYMBOL_attrsARRAY) + { + assert (!(sa & ~(FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsTYPE))); + + error = TRUE; + } + else if (sa & FFESYMBOL_attrsSFARG) + { + assert (!(sa & ~(FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))); + + error = TRUE; + } + else if (sa & FFESYMBOL_attrsTYPE) + { + assert (!(sa & (FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG))); /* Handled above. */ + assert (!(sa & ~(FFESYMBOL_attrsTYPE + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG))); + + if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN)) + error = TRUE; + else + { + kind = FFEINFO_kindFUNCTION; + where = FFEINFO_whereGLOBAL; + } + } + else if (sa == FFESYMBOL_attrsetNONE) + { + assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); + kind = FFEINFO_kindFUNCTION; + where = FFEINFO_whereGLOBAL; + needs_type = TRUE; + } + else + error = TRUE; + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (error) + ffesymbol_error (s, t); + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_signal_change (s); /* May need to back up to previous + version. */ + if (needs_type && !ffeimplic_establish_symbol (s)) + { + ffesymbol_error (s, t); + return s; + } + if (!ffesymbol_explicitwhere (s)) + { + ffebad_start (FFEBAD_NEED_EXTERNAL); + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_string (ffesymbol_text (s)); + ffebad_finish (); + ffesymbol_set_explicitwhere (s, TRUE); + } + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + ffesymbol_rank (s), + kind, /* FUNCTION. */ + where, /* GLOBAL or DUMMY. */ + ffesymbol_size (s))); + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_resolve_intrin (s); + ffesymbol_reference (s, t, FALSE); + s = ffecom_sym_learned (s); + ffesymbol_signal_unreported (s); /* For debugging purposes. */ + } + + return s; +} + +/* Have FOO in DATA (stuff,FOO=1,10)/.../. */ + +static ffesymbol +ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t) +{ + ffesymbolState ss; + + /* If the symbol isn't in the sfunc name space, pretend as though we saw a + reference to it already within the imp-DO construct at this level, so as + to get a symbol that is in the sfunc name space. But this is an + erroneous construct, and should be caught elsewhere. */ + + if (ffesymbol_sfdummyparent (s) == NULL) + { + s = ffeexpr_sym_impdoitem_ (s, t); + if (ffesymbol_sfdummyparent (s) == NULL) + { /* PARAMETER FOO...DATA (A(I),FOO=...). */ + ffesymbol_error (s, t); + return s; + } + } + + ss = ffesymbol_state (s); + + switch (ss) + { + case FFESYMBOL_stateNONE: /* Used as iterator already. */ + if (ffeexpr_level_ < ffesymbol_maxentrynum (s)) + ffesymbol_error (s, t); /* Can't reuse dead iterator. F90 disallows + this; F77 allows it but it is a stupid + feature. */ + else + { /* Can use dead iterator because we're at at + least a innermore (higher-numbered) level + than the iterator's outermost + (lowest-numbered) level. This should be + diagnosed later, because it means an item + in this list didn't reference this + iterator. */ +#if 1 + ffesymbol_error (s, t); /* For now, complain. */ +#else /* Someday will detect all cases where initializer doesn't reference + all applicable iterators, in which case reenable this code. */ + ffesymbol_signal_change (s); + ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN); + ffesymbol_set_maxentrynum (s, ffeexpr_level_); + ffesymbol_signal_unreported (s); +#endif + } + break; + + case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO. + If seen in outermore level, can't be an + iterator here, so complain. If not seen + at current level, complain for now, + because that indicates something F90 + rejects (though we currently don't detect + all such cases for now). */ + if (ffeexpr_level_ <= ffesymbol_maxentrynum (s)) + { + ffesymbol_signal_change (s); + ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN); + ffesymbol_signal_unreported (s); + } + else + ffesymbol_error (s, t); + break; + + case FFESYMBOL_stateUNCERTAIN: /* Already iterator! */ + assert ("DATA implied-DO control var seen twice!!" == NULL); + ffesymbol_error (s, t); + break; + + case FFESYMBOL_stateUNDERSTOOD: + break; /* ANY. */ + + default: + assert ("Foo Bletch!!" == NULL); + break; + } + + return s; +} + +/* Have FOO in PARAMETER (FOO=...). */ + +static ffesymbol +ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t) +{ + ffesymbolAttrs sa; + + sa = ffesymbol_attrs (s); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + if (sa & ~(FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsTYPE)) + { + if (!(sa & FFESYMBOL_attrsANY)) + ffesymbol_error (s, t); + } + else + { + ffesymbol_signal_change (s); /* May need to back up to previous + version. */ + if (!ffeimplic_establish_symbol (s)) + { + ffesymbol_error (s, t); + return s; + } + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + ffesymbol_rank (s), + FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + ffesymbol_size (s))); + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_resolve_intrin (s); + s = ffecom_sym_learned (s); + ffesymbol_signal_unreported (s); /* For debugging purposes. */ + } + + return s; +} + +/* Have FOO in CALL XYZ(...,FOO,...). Does not include any other + embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1). */ + +static ffesymbol +ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t) +{ + ffesymbolAttrs sa; + ffesymbolAttrs na; + ffeinfoKind kind; + ffeinfoWhere where; + ffesymbolState ns; + bool needs_type = FALSE; + + assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) + || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); + + na = sa = ffesymbol_attrs (s); + + assert (!(sa & ~(FFESYMBOL_attrsACTUALARG + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))); + + kind = ffesymbol_kind (s); + where = ffesymbol_where (s); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + ns = FFESYMBOL_stateUNDERSTOOD; + + if (sa & FFESYMBOL_attrsEXTERNAL) + { + assert (!(sa & ~(FFESYMBOL_attrsACTUALARG + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsTYPE))); + + if (sa & FFESYMBOL_attrsTYPE) + where = FFEINFO_whereGLOBAL; + else + /* Not TYPE. */ + { + ns = FFESYMBOL_stateUNCERTAIN; + + if (sa & FFESYMBOL_attrsDUMMY) + assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */ + else if (sa & FFESYMBOL_attrsACTUALARG) + ; /* Not DUMMY or TYPE. */ + else + /* Not ACTUALARG, DUMMY, or TYPE. */ + { + assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */ + na |= FFESYMBOL_attrsACTUALARG; + where = FFEINFO_whereGLOBAL; + } + } + } + else if (sa & FFESYMBOL_attrsDUMMY) + { + assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ + assert (!(sa & ~(FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsTYPE))); + + kind = FFEINFO_kindENTITY; + if (!(sa & FFESYMBOL_attrsTYPE)) + needs_type = TRUE; + } + else if (sa & FFESYMBOL_attrsARRAY) + { + assert (!(sa & ~(FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsTYPE))); + + where = FFEINFO_whereLOCAL; + } + else if (sa & FFESYMBOL_attrsSFARG) + { + assert (!(sa & ~(FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))); + + where = FFEINFO_whereLOCAL; + } + else if (sa & FFESYMBOL_attrsTYPE) + { + assert (!(sa & (FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG))); /* Handled above. */ + assert (!(sa & ~(FFESYMBOL_attrsTYPE + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG))); + + if (sa & FFESYMBOL_attrsANYLEN) + ns = FFESYMBOL_stateNONE; + else + { + kind = FFEINFO_kindENTITY; + where = FFEINFO_whereLOCAL; + } + } + else if (sa == FFESYMBOL_attrsetNONE) + { + /* New state is left empty because there isn't any state flag to + set for this case, and it's UNDERSTOOD after all. */ + assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); + kind = FFEINFO_kindENTITY; + where = FFEINFO_whereLOCAL; + needs_type = TRUE; + } + else + ns = FFESYMBOL_stateNONE; /* Error. */ + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (ns == FFESYMBOL_stateNONE) + ffesymbol_error (s, t); + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_signal_change (s); /* May need to back up to previous + version. */ + if (needs_type && !ffeimplic_establish_symbol (s)) + { + ffesymbol_error (s, t); + return s; + } + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + ffesymbol_rank (s), + kind, + where, + ffesymbol_size (s))); + ffesymbol_set_attrs (s, na); + ffesymbol_set_state (s, ns); + s = ffecom_sym_learned (s); + ffesymbol_reference (s, t, FALSE); + ffesymbol_signal_unreported (s); /* For debugging purposes. */ + } + + return s; +} + +/* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing + a reference to FOO. */ + +static ffesymbol +ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t) +{ + ffesymbolAttrs sa; + ffesymbolAttrs na; + ffeinfoKind kind; + ffeinfoWhere where; + + na = sa = ffesymbol_attrs (s); + kind = FFEINFO_kindENTITY; + where = ffesymbol_where (s); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + if (!(sa & ~(FFESYMBOL_attrsADJUSTS + | FFESYMBOL_attrsCOMMON + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEQUIV + | FFESYMBOL_attrsINIT + | FFESYMBOL_attrsNAMELIST + | FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))) + na = sa | FFESYMBOL_attrsADJUSTS; + else + na = FFESYMBOL_attrsetNONE; + + /* Since this symbol definitely is going into an expression (the + dimension-list for some dummy array, presumably), figure out WHERE if + possible. */ + + if (where == FFEINFO_whereNONE) + { + if (na & (FFESYMBOL_attrsCOMMON + | FFESYMBOL_attrsEQUIV + | FFESYMBOL_attrsINIT + | FFESYMBOL_attrsNAMELIST)) + where = FFEINFO_whereCOMMON; + else if (na & FFESYMBOL_attrsDUMMY) + where = FFEINFO_whereDUMMY; + } + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (na == FFESYMBOL_attrsetNONE) + ffesymbol_error (s, t); + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_signal_change (s); /* May need to back up to previous + version. */ + if (!ffeimplic_establish_symbol (s)) + { + ffesymbol_error (s, t); + return s; + } + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + ffesymbol_rank (s), + kind, /* Always ENTITY. */ + where, /* NONE, COMMON, or DUMMY. */ + ffesymbol_size (s))); + ffesymbol_set_attrs (s, na); + ffesymbol_set_state (s, FFESYMBOL_stateSEEN); + ffesymbol_resolve_intrin (s); + ffesymbol_signal_unreported (s); /* For debugging purposes. */ + } + + return s; +} + +/* Have FOO in XYZ = ...FOO.... Does not include cases like FOO in + XYZ = BAR(FOO), as such cases are handled elsewhere. */ + +static ffesymbol +ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t) +{ + ffesymbolAttrs sa; + ffesymbolAttrs na; + ffeinfoKind kind; + ffeinfoWhere where; + bool error = FALSE; + + assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) + || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); + + na = sa = ffesymbol_attrs (s); + + assert (!(sa & ~(FFESYMBOL_attrsACTUALARG + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))); + + kind = ffesymbol_kind (s); + where = ffesymbol_where (s); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + if (sa & FFESYMBOL_attrsEXTERNAL) + { + assert (!(sa & ~(FFESYMBOL_attrsACTUALARG + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsTYPE))); + + error = TRUE; + } + else if (sa & FFESYMBOL_attrsDUMMY) + { + assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ + assert (!(sa & ~(FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsTYPE))); + + kind = FFEINFO_kindENTITY; + } + else if (sa & FFESYMBOL_attrsARRAY) + { + assert (!(sa & ~(FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsTYPE))); + + where = FFEINFO_whereLOCAL; + } + else if (sa & FFESYMBOL_attrsSFARG) + { + assert (!(sa & ~(FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))); + + where = FFEINFO_whereLOCAL; + } + else if (sa & FFESYMBOL_attrsTYPE) + { + assert (!(sa & (FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG))); /* Handled above. */ + assert (!(sa & ~(FFESYMBOL_attrsTYPE + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG))); + + if (sa & FFESYMBOL_attrsANYLEN) + error = TRUE; + else + { + kind = FFEINFO_kindENTITY; + where = FFEINFO_whereLOCAL; + } + } + else if (sa == FFESYMBOL_attrsetNONE) + { + assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); + kind = FFEINFO_kindENTITY; + where = FFEINFO_whereLOCAL; + } + else + error = TRUE; + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (error) + ffesymbol_error (s, t); + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_signal_change (s); /* May need to back up to previous + version. */ + if (!ffeimplic_establish_symbol (s)) + { + ffesymbol_error (s, t); + return s; + } + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + ffesymbol_rank (s), + kind, /* ENTITY. */ + where, /* LOCAL. */ + ffesymbol_size (s))); + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_resolve_intrin (s); + s = ffecom_sym_learned (s); + ffesymbol_signal_unreported (s); /* For debugging purposes. */ + } + + return s; +} + +/* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand + + ffelexToken t; + bool maybe_intrin; + ffeexprParenType_ paren_type; + ffesymbol s; + s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type); + + Just like ffesymbol_declare_local, except performs any implicit info + assignment necessary, and it returns the type of the parenthesized list + (list of function args, list of array args, or substring spec). */ + +static ffesymbol +ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin, + ffeexprParenType_ *paren_type) +{ + ffesymbol s; + ffesymbolState st; /* Effective state. */ + ffeinfoKind k; + bool bad; + + if (maybe_intrin && ffesrc_check_symbol ()) + { /* Knock off some easy cases. */ + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextSUBROUTINEREF: + case FFEEXPR_contextDATA: + case FFEEXPR_contextDATAIMPDOINDEX_: + case FFEEXPR_contextSFUNCDEF: + case FFEEXPR_contextSFUNCDEFINDEX_: + case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: + case FFEEXPR_contextLET: + case FFEEXPR_contextPAREN_: + case FFEEXPR_contextACTUALARGEXPR_: + case FFEEXPR_contextINDEXORACTUALARGEXPR_: + case FFEEXPR_contextIOLIST: + case FFEEXPR_contextIOLISTDF: + case FFEEXPR_contextDO: + case FFEEXPR_contextDOWHILE: + case FFEEXPR_contextACTUALARG_: + case FFEEXPR_contextCGOTO: + case FFEEXPR_contextIF: + case FFEEXPR_contextARITHIF: + case FFEEXPR_contextFORMAT: + case FFEEXPR_contextSTOP: + case FFEEXPR_contextRETURN: + case FFEEXPR_contextSELECTCASE: + case FFEEXPR_contextCASE: + case FFEEXPR_contextFILEASSOC: + case FFEEXPR_contextFILEINT: + case FFEEXPR_contextFILEDFINT: + case FFEEXPR_contextFILELOG: + case FFEEXPR_contextFILENUM: + case FFEEXPR_contextFILENUMAMBIG: + case FFEEXPR_contextFILECHAR: + case FFEEXPR_contextFILENUMCHAR: + case FFEEXPR_contextFILEDFCHAR: + case FFEEXPR_contextFILEKEY: + case FFEEXPR_contextFILEUNIT: + case FFEEXPR_contextFILEUNIT_DF: + case FFEEXPR_contextFILEUNITAMBIG: + case FFEEXPR_contextFILEFORMAT: + case FFEEXPR_contextFILENAMELIST: + case FFEEXPR_contextFILEVXTCODE: + case FFEEXPR_contextINDEX_: + case FFEEXPR_contextIMPDOITEM_: + case FFEEXPR_contextIMPDOITEMDF_: + case FFEEXPR_contextIMPDOCTRL_: + case FFEEXPR_contextDATAIMPDOCTRL_: + case FFEEXPR_contextCHARACTERSIZE: + case FFEEXPR_contextPARAMETER: + case FFEEXPR_contextDIMLIST: + case FFEEXPR_contextDIMLISTCOMMON: + case FFEEXPR_contextKINDTYPE: + case FFEEXPR_contextINITVAL: + case FFEEXPR_contextEQVINDEX_: + break; /* These could be intrinsic invocations. */ + + case FFEEXPR_contextAGOTO: + case FFEEXPR_contextFILEFORMATNML: + case FFEEXPR_contextALLOCATE: + case FFEEXPR_contextDEALLOCATE: + case FFEEXPR_contextHEAPSTAT: + case FFEEXPR_contextNULLIFY: + case FFEEXPR_contextINCLUDE: + case FFEEXPR_contextDATAIMPDOITEM_: + case FFEEXPR_contextLOC_: + case FFEEXPR_contextINDEXORACTUALARG_: + case FFEEXPR_contextSFUNCDEFACTUALARG_: + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + case FFEEXPR_contextPARENFILENUM_: + case FFEEXPR_contextPARENFILEUNIT_: + maybe_intrin = FALSE; + break; /* Can't be intrinsic invocation. */ + + default: + assert ("blah! blah! waaauuggh!" == NULL); + break; + } + } + + s = ffesymbol_declare_local (t, maybe_intrin); + + switch (ffeexpr_context_outer_ (ffeexpr_stack_)) + /* Special-case these since they can involve a different concept + of "state" (in the stmtfunc name space). */ + { + case FFEEXPR_contextDATAIMPDOINDEX_: + case FFEEXPR_contextDATAIMPDOCTRL_: + if (ffeexpr_context_outer_ (ffeexpr_stack_) + == FFEEXPR_contextDATAIMPDOINDEX_) + s = ffeexpr_sym_impdoitem_ (s, t); + else + if (ffeexpr_stack_->is_rhs) + s = ffeexpr_sym_impdoitem_ (s, t); + else + s = ffeexpr_sym_lhs_impdoctrl_ (s, t); + if (ffesymbol_kind (s) != FFEINFO_kindANY) + ffesymbol_error (s, t); + return s; + + default: + break; + } + + switch ((ffesymbol_sfdummyparent (s) == NULL) + ? ffesymbol_state (s) + : FFESYMBOL_stateUNDERSTOOD) + { + case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr + context. */ + if (!ffest_seen_first_exec ()) + goto seen; /* :::::::::::::::::::: */ + /* Fall through. */ + case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */ + switch (ffeexpr_context_outer_ (ffeexpr_stack_)) + { + case FFEEXPR_contextSUBROUTINEREF: + s = ffeexpr_sym_lhs_call_ (s, t); /* "CALL FOO"=="CALL + FOO(...)". */ + break; + + case FFEEXPR_contextDATA: + if (ffeexpr_stack_->is_rhs) + s = ffeexpr_sym_rhs_let_ (s, t); + else + s = ffeexpr_sym_lhs_data_ (s, t); + break; + + case FFEEXPR_contextDATAIMPDOITEM_: + s = ffeexpr_sym_lhs_data_ (s, t); + break; + + case FFEEXPR_contextSFUNCDEF: + case FFEEXPR_contextSFUNCDEFINDEX_: + case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: + s = ffecom_sym_exec_transition (s); + if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) + goto understood; /* :::::::::::::::::::: */ + /* Fall through. */ + case FFEEXPR_contextLET: + case FFEEXPR_contextPAREN_: + case FFEEXPR_contextACTUALARGEXPR_: + case FFEEXPR_contextINDEXORACTUALARGEXPR_: + case FFEEXPR_contextIOLIST: + case FFEEXPR_contextIOLISTDF: + case FFEEXPR_contextDO: + case FFEEXPR_contextDOWHILE: + case FFEEXPR_contextACTUALARG_: + case FFEEXPR_contextCGOTO: + case FFEEXPR_contextIF: + case FFEEXPR_contextARITHIF: + case FFEEXPR_contextFORMAT: + case FFEEXPR_contextSTOP: + case FFEEXPR_contextRETURN: + case FFEEXPR_contextSELECTCASE: + case FFEEXPR_contextCASE: + case FFEEXPR_contextFILEASSOC: + case FFEEXPR_contextFILEINT: + case FFEEXPR_contextFILEDFINT: + case FFEEXPR_contextFILELOG: + case FFEEXPR_contextFILENUM: + case FFEEXPR_contextFILENUMAMBIG: + case FFEEXPR_contextFILECHAR: + case FFEEXPR_contextFILENUMCHAR: + case FFEEXPR_contextFILEDFCHAR: + case FFEEXPR_contextFILEKEY: + case FFEEXPR_contextFILEUNIT: + case FFEEXPR_contextFILEUNIT_DF: + case FFEEXPR_contextFILEUNITAMBIG: + case FFEEXPR_contextFILEFORMAT: + case FFEEXPR_contextFILENAMELIST: + case FFEEXPR_contextFILEVXTCODE: + case FFEEXPR_contextINDEX_: + case FFEEXPR_contextIMPDOITEM_: + case FFEEXPR_contextIMPDOITEMDF_: + case FFEEXPR_contextIMPDOCTRL_: + case FFEEXPR_contextLOC_: + if (ffeexpr_stack_->is_rhs) + s = ffeexpr_paren_rhs_let_ (s, t); + else + s = ffeexpr_paren_lhs_let_ (s, t); + break; + + case FFEEXPR_contextASSIGN: + case FFEEXPR_contextAGOTO: + case FFEEXPR_contextCHARACTERSIZE: + case FFEEXPR_contextEQUIVALENCE: + case FFEEXPR_contextINCLUDE: + case FFEEXPR_contextPARAMETER: + case FFEEXPR_contextDIMLIST: + case FFEEXPR_contextDIMLISTCOMMON: + case FFEEXPR_contextKINDTYPE: + case FFEEXPR_contextINITVAL: + case FFEEXPR_contextEQVINDEX_: + break; /* Will turn into errors below. */ + + default: + ffesymbol_error (s, t); + break; + } + /* Fall through. */ + case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */ + understood: /* :::::::::::::::::::: */ + + /* State might have changed, update it. */ + st = ((ffesymbol_sfdummyparent (s) == NULL) + ? ffesymbol_state (s) + : FFESYMBOL_stateUNDERSTOOD); + + k = ffesymbol_kind (s); + switch (ffeexpr_context_outer_ (ffeexpr_stack_)) + { + case FFEEXPR_contextSUBROUTINEREF: + bad = ((k != FFEINFO_kindSUBROUTINE) + && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC) + || (k != FFEINFO_kindNONE))); + break; + + case FFEEXPR_contextDATA: + if (ffeexpr_stack_->is_rhs) + bad = (k != FFEINFO_kindENTITY) + || (ffesymbol_where (s) != FFEINFO_whereCONSTANT); + else + bad = (k != FFEINFO_kindENTITY) + || ((ffesymbol_where (s) != FFEINFO_whereNONE) + && (ffesymbol_where (s) != FFEINFO_whereLOCAL) + && (ffesymbol_where (s) != FFEINFO_whereCOMMON)); + break; + + case FFEEXPR_contextDATAIMPDOITEM_: + bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0) + || ((ffesymbol_where (s) != FFEINFO_whereNONE) + && (ffesymbol_where (s) != FFEINFO_whereLOCAL) + && (ffesymbol_where (s) != FFEINFO_whereCOMMON)); + break; + + case FFEEXPR_contextSFUNCDEF: + case FFEEXPR_contextSFUNCDEFINDEX_: + case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: + case FFEEXPR_contextLET: + case FFEEXPR_contextPAREN_: + case FFEEXPR_contextACTUALARGEXPR_: + case FFEEXPR_contextINDEXORACTUALARGEXPR_: + case FFEEXPR_contextIOLIST: + case FFEEXPR_contextIOLISTDF: + case FFEEXPR_contextDO: + case FFEEXPR_contextDOWHILE: + case FFEEXPR_contextACTUALARG_: + case FFEEXPR_contextCGOTO: + case FFEEXPR_contextIF: + case FFEEXPR_contextARITHIF: + case FFEEXPR_contextFORMAT: + case FFEEXPR_contextSTOP: + case FFEEXPR_contextRETURN: + case FFEEXPR_contextSELECTCASE: + case FFEEXPR_contextCASE: + case FFEEXPR_contextFILEASSOC: + case FFEEXPR_contextFILEINT: + case FFEEXPR_contextFILEDFINT: + case FFEEXPR_contextFILELOG: + case FFEEXPR_contextFILENUM: + case FFEEXPR_contextFILENUMAMBIG: + case FFEEXPR_contextFILECHAR: + case FFEEXPR_contextFILENUMCHAR: + case FFEEXPR_contextFILEDFCHAR: + case FFEEXPR_contextFILEKEY: + case FFEEXPR_contextFILEUNIT: + case FFEEXPR_contextFILEUNIT_DF: + case FFEEXPR_contextFILEUNITAMBIG: + case FFEEXPR_contextFILEFORMAT: + case FFEEXPR_contextFILENAMELIST: + case FFEEXPR_contextFILEVXTCODE: + case FFEEXPR_contextINDEX_: + case FFEEXPR_contextIMPDOITEM_: + case FFEEXPR_contextIMPDOITEMDF_: + case FFEEXPR_contextIMPDOCTRL_: + case FFEEXPR_contextLOC_: + bad = FALSE; /* Let paren-switch handle the cases. */ + break; + + case FFEEXPR_contextASSIGN: + case FFEEXPR_contextAGOTO: + case FFEEXPR_contextCHARACTERSIZE: + case FFEEXPR_contextEQUIVALENCE: + case FFEEXPR_contextPARAMETER: + case FFEEXPR_contextDIMLIST: + case FFEEXPR_contextDIMLISTCOMMON: + case FFEEXPR_contextKINDTYPE: + case FFEEXPR_contextINITVAL: + case FFEEXPR_contextEQVINDEX_: + bad = (k != FFEINFO_kindENTITY) + || (ffesymbol_where (s) != FFEINFO_whereCONSTANT); + break; + + case FFEEXPR_contextINCLUDE: + bad = TRUE; + break; + + default: + bad = TRUE; + break; + } + + switch (bad ? FFEINFO_kindANY : k) + { + case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */ + if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC) + { + if (ffeexpr_context_outer_ (ffeexpr_stack_) + == FFEEXPR_contextSUBROUTINEREF) + *paren_type = FFEEXPR_parentypeSUBROUTINE_; + else + *paren_type = FFEEXPR_parentypeFUNCTION_; + break; + } + if (st == FFESYMBOL_stateUNDERSTOOD) + { + bad = TRUE; + *paren_type = FFEEXPR_parentypeANY_; + } + else + *paren_type = FFEEXPR_parentypeFUNSUBSTR_; + break; + + case FFEINFO_kindFUNCTION: + *paren_type = FFEEXPR_parentypeFUNCTION_; + switch (ffesymbol_where (s)) + { + case FFEINFO_whereLOCAL: + bad = TRUE; /* Attempt to recurse! */ + break; + + case FFEINFO_whereCONSTANT: + bad = ((ffesymbol_sfexpr (s) == NULL) + || (ffebld_op (ffesymbol_sfexpr (s)) + == FFEBLD_opANY)); /* Attempt to recurse! */ + break; + + default: + break; + } + break; + + case FFEINFO_kindSUBROUTINE: + if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF) + || (ffeexpr_stack_->previous != NULL)) + { + bad = TRUE; + *paren_type = FFEEXPR_parentypeANY_; + break; + } + + *paren_type = FFEEXPR_parentypeSUBROUTINE_; + switch (ffesymbol_where (s)) + { + case FFEINFO_whereLOCAL: + case FFEINFO_whereCONSTANT: + bad = TRUE; /* Attempt to recurse! */ + break; + + default: + break; + } + break; + + case FFEINFO_kindENTITY: + if (ffesymbol_rank (s) == 0) + if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER) + *paren_type = FFEEXPR_parentypeSUBSTRING_; + else + { + bad = TRUE; + *paren_type = FFEEXPR_parentypeANY_; + } + else + *paren_type = FFEEXPR_parentypeARRAY_; + break; + + default: + case FFEINFO_kindANY: + bad = TRUE; + *paren_type = FFEEXPR_parentypeANY_; + break; + } + + if (bad) + { + if (k == FFEINFO_kindANY) + ffest_shutdown (); + else + ffesymbol_error (s, t); + } + + return s; + + case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */ + seen: /* :::::::::::::::::::: */ + bad = TRUE; + switch (ffeexpr_context_outer_ (ffeexpr_stack_)) + { + case FFEEXPR_contextPARAMETER: + if (ffeexpr_stack_->is_rhs) + ffesymbol_error (s, t); + else + s = ffeexpr_sym_lhs_parameter_ (s, t); + break; + + case FFEEXPR_contextDATA: + s = ffecom_sym_exec_transition (s); + if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) + goto understood; /* :::::::::::::::::::: */ + if (ffeexpr_stack_->is_rhs) + ffesymbol_error (s, t); + else + s = ffeexpr_sym_lhs_data_ (s, t); + goto understood; /* :::::::::::::::::::: */ + + case FFEEXPR_contextDATAIMPDOITEM_: + s = ffecom_sym_exec_transition (s); + if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) + goto understood; /* :::::::::::::::::::: */ + s = ffeexpr_sym_lhs_data_ (s, t); + goto understood; /* :::::::::::::::::::: */ + + case FFEEXPR_contextEQUIVALENCE: + s = ffeexpr_sym_lhs_equivalence_ (s, t); + bad = FALSE; + break; + + case FFEEXPR_contextDIMLIST: + s = ffeexpr_sym_rhs_dimlist_ (s, t); + break; + + case FFEEXPR_contextCHARACTERSIZE: + case FFEEXPR_contextKINDTYPE: + case FFEEXPR_contextDIMLISTCOMMON: + case FFEEXPR_contextINITVAL: + case FFEEXPR_contextEQVINDEX_: + break; + + case FFEEXPR_contextINCLUDE: + break; + + case FFEEXPR_contextINDEX_: + case FFEEXPR_contextACTUALARGEXPR_: + case FFEEXPR_contextINDEXORACTUALARGEXPR_: + case FFEEXPR_contextSFUNCDEF: + case FFEEXPR_contextSFUNCDEFINDEX_: + case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: + assert (ffeexpr_stack_->is_rhs); + s = ffecom_sym_exec_transition (s); + if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD) + goto understood; /* :::::::::::::::::::: */ + s = ffeexpr_paren_rhs_let_ (s, t); + goto understood; /* :::::::::::::::::::: */ + + default: + break; + } + k = ffesymbol_kind (s); + switch (bad ? FFEINFO_kindANY : k) + { + case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */ + *paren_type = FFEEXPR_parentypeFUNSUBSTR_; + break; + + case FFEINFO_kindFUNCTION: + *paren_type = FFEEXPR_parentypeFUNCTION_; + switch (ffesymbol_where (s)) + { + case FFEINFO_whereLOCAL: + bad = TRUE; /* Attempt to recurse! */ + break; + + case FFEINFO_whereCONSTANT: + bad = ((ffesymbol_sfexpr (s) == NULL) + || (ffebld_op (ffesymbol_sfexpr (s)) + == FFEBLD_opANY)); /* Attempt to recurse! */ + break; + + default: + break; + } + break; + + case FFEINFO_kindSUBROUTINE: + *paren_type = FFEEXPR_parentypeANY_; + bad = TRUE; /* Cannot possibly be in + contextSUBROUTINEREF. */ + break; + + case FFEINFO_kindENTITY: + if (ffesymbol_rank (s) == 0) + if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE) + *paren_type = FFEEXPR_parentypeEQUIVALENCE_; + else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER) + *paren_type = FFEEXPR_parentypeSUBSTRING_; + else + { + bad = TRUE; + *paren_type = FFEEXPR_parentypeANY_; + } + else + *paren_type = FFEEXPR_parentypeARRAY_; + break; + + default: + case FFEINFO_kindANY: + bad = TRUE; + *paren_type = FFEEXPR_parentypeANY_; + break; + } + + if (bad) + { + if (k == FFEINFO_kindANY) + ffest_shutdown (); + else + ffesymbol_error (s, t); + } + + return s; + + default: + assert ("bad symbol state" == NULL); + return NULL; + } +} + +/* Have FOO in XYZ = ...FOO(...).... Executable context only. */ + +static ffesymbol +ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t) +{ + ffesymbolAttrs sa; + ffesymbolAttrs na; + ffeinfoKind kind; + ffeinfoWhere where; + ffeintrinGen gen; + ffeintrinSpec spec; + ffeintrinImp imp; + bool maybe_ambig = FALSE; + bool error = FALSE; + + assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE) + || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN)); + + na = sa = ffesymbol_attrs (s); + + assert (!(sa & ~(FFESYMBOL_attrsACTUALARG + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))); + + kind = ffesymbol_kind (s); + where = ffesymbol_where (s); + + /* Figure out what kind of object we've got based on previous declarations + of or references to the object. */ + + if (sa & FFESYMBOL_attrsEXTERNAL) + { + assert (!(sa & ~(FFESYMBOL_attrsACTUALARG + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsTYPE))); + + if (sa & FFESYMBOL_attrsTYPE) + where = FFEINFO_whereGLOBAL; + else + /* Not TYPE. */ + { + kind = FFEINFO_kindFUNCTION; + + if (sa & FFESYMBOL_attrsDUMMY) + ; /* Not TYPE. */ + else if (sa & FFESYMBOL_attrsACTUALARG) + ; /* Not DUMMY or TYPE. */ + else /* Not ACTUALARG, DUMMY, or TYPE. */ + where = FFEINFO_whereGLOBAL; + } + } + else if (sa & FFESYMBOL_attrsDUMMY) + { + assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */ + assert (!(sa & ~(FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsTYPE))); + + kind = FFEINFO_kindFUNCTION; + maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; kind + could be ENTITY w/substring ref. */ + } + else if (sa & FFESYMBOL_attrsARRAY) + { + assert (!(sa & ~(FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsTYPE))); + + where = FFEINFO_whereLOCAL; + } + else if (sa & FFESYMBOL_attrsSFARG) + { + assert (!(sa & ~(FFESYMBOL_attrsSFARG + | FFESYMBOL_attrsTYPE))); + + where = FFEINFO_whereLOCAL; /* Actually an error, but at least we + know it's a local var. */ + } + else if (sa & FFESYMBOL_attrsTYPE) + { + assert (!(sa & (FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG))); /* Handled above. */ + assert (!(sa & ~(FFESYMBOL_attrsTYPE + | FFESYMBOL_attrsADJUSTABLE + | FFESYMBOL_attrsANYLEN + | FFESYMBOL_attrsARRAY + | FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsEXTERNAL + | FFESYMBOL_attrsSFARG))); + + if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE, + &gen, &spec, &imp)) + { + if (!(sa & FFESYMBOL_attrsANYLEN) + && (ffeimplic_peek_symbol_type (s, NULL) + == FFEINFO_basictypeCHARACTER)) + return s; /* Haven't learned anything yet. */ + + ffesymbol_signal_change (s); /* May need to back up to previous + version. */ + ffesymbol_set_generic (s, gen); + ffesymbol_set_specific (s, spec); + ffesymbol_set_implementation (s, imp); + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + 0, + FFEINFO_kindFUNCTION, + FFEINFO_whereINTRINSIC, + ffesymbol_size (s))); + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_resolve_intrin (s); + ffesymbol_reference (s, t, FALSE); + s = ffecom_sym_learned (s); + ffesymbol_signal_unreported (s); /* For debugging purposes. */ + + return s; + } + if (sa & FFESYMBOL_attrsANYLEN) + error = TRUE; /* Error, since the only way we can, + given CHARACTER*(*) FOO, accept + FOO(...) is for FOO to be a dummy + arg or constant, but it can't + become either now. */ + else if (sa & FFESYMBOL_attrsADJUSTABLE) + { + kind = FFEINFO_kindENTITY; + where = FFEINFO_whereLOCAL; + } + else + { + kind = FFEINFO_kindFUNCTION; + where = FFEINFO_whereGLOBAL; + maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; + could be ENTITY/LOCAL w/substring ref. */ + } + } + else if (sa == FFESYMBOL_attrsetNONE) + { + assert (ffesymbol_state (s) == FFESYMBOL_stateNONE); + + if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE, + &gen, &spec, &imp)) + { + if (ffeimplic_peek_symbol_type (s, NULL) + == FFEINFO_basictypeCHARACTER) + return s; /* Haven't learned anything yet. */ + + ffesymbol_signal_change (s); /* May need to back up to previous + version. */ + ffesymbol_set_generic (s, gen); + ffesymbol_set_specific (s, spec); + ffesymbol_set_implementation (s, imp); + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + 0, + FFEINFO_kindFUNCTION, + FFEINFO_whereINTRINSIC, + ffesymbol_size (s))); + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_resolve_intrin (s); + s = ffecom_sym_learned (s); + ffesymbol_reference (s, t, FALSE); + ffesymbol_signal_unreported (s); /* For debugging purposes. */ + return s; + } + + kind = FFEINFO_kindFUNCTION; + where = FFEINFO_whereGLOBAL; + maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; + could be ENTITY/LOCAL w/substring ref. */ + } + else + error = TRUE; + + /* Now see what we've got for a new object: NONE means a new error cropped + up; ANY means an old error to be ignored; otherwise, everything's ok, + update the object (symbol) and continue on. */ + + if (error) + ffesymbol_error (s, t); + else if (!(na & FFESYMBOL_attrsANY)) + { + ffesymbol_signal_change (s); /* May need to back up to previous + version. */ + if (!ffeimplic_establish_symbol (s)) + { + ffesymbol_error (s, t); + return s; + } + if (maybe_ambig + && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)) + return s; /* Still not sure, let caller deal with it + based on (...). */ + + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + ffesymbol_rank (s), + kind, + where, + ffesymbol_size (s))); + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_resolve_intrin (s); + s = ffecom_sym_learned (s); + ffesymbol_reference (s, t, FALSE); + ffesymbol_signal_unreported (s); /* For debugging purposes. */ + } + + return s; +} + +/* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Handle expression (which might be null) and COMMA or CLOSE_PAREN. */ + +static ffelexHandler +ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + ffeexprExpr_ procedure; + ffebld reduced; + ffeinfo info; + ffeexprContext ctx; + bool check_intrin = FALSE; /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */ + + procedure = ffeexpr_stack_->exprstack; + info = ffebld_info (procedure->u.operand); + + if (ffeinfo_where (info) == FFEINFO_whereCONSTANT) + { /* Statement function (or subroutine, if + there was such a thing). */ + if ((expr == NULL) + && ((ffe_is_pedantic () + && (ffeexpr_stack_->expr != NULL)) + || (ffelex_token_type (t) == FFELEX_typeCOMMA))) + { + if (ffebad_start (FFEBAD_NULL_ARGUMENT)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), + ffelex_token_where_column (ffeexpr_stack_->tokens[0])); + ffebad_here (1, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_finish (); + } + if (ffeexpr_stack_->next_dummy != NULL) + { /* Don't bother if we're going to complain + later! */ + expr = ffebld_new_conter + (ffebld_constant_new_integerdefault_val (0)); + ffebld_set_info (expr, ffeinfo_new_any ()); + } + } + + if (expr == NULL) + ; + else + { + if (ffeexpr_stack_->next_dummy == NULL) + { /* Report later which was the first extra + argument. */ + if (ffeexpr_stack_->tokens[1] == NULL) + { + ffeexpr_stack_->tokens[1] = ffelex_token_use (ft); + ffeexpr_stack_->num_args = 0; + } + ++ffeexpr_stack_->num_args; /* Count # of extra + arguments. */ + } + else + { + if (ffeinfo_rank (ffebld_info (expr)) != 0) + { + if (ffebad_start (FFEBAD_ARRAY_AS_SFARG)) + { + ffebad_here (0, + ffelex_token_where_line (ffeexpr_stack_->tokens[0]), + ffelex_token_where_column (ffeexpr_stack_->tokens[0])); + ffebad_here (1, ffelex_token_where_line (ft), + ffelex_token_where_column (ft)); + ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent + (ffebld_symter (ffebld_head + (ffeexpr_stack_->next_dummy))))); + ffebad_finish (); + } + } + else + { + expr = ffeexpr_convert_expr (expr, ft, + ffebld_head (ffeexpr_stack_->next_dummy), + ffeexpr_stack_->tokens[0], + FFEEXPR_contextLET); + ffebld_append_item (&ffeexpr_stack_->bottom, expr); + } + --ffeexpr_stack_->num_args; /* Count down # of args. */ + ffeexpr_stack_->next_dummy + = ffebld_trail (ffeexpr_stack_->next_dummy); + } + } + } + else if ((expr != NULL) || ffe_is_ugly_comma () + || (ffelex_token_type (t) == FFELEX_typeCOMMA)) + ffebld_append_item (&ffeexpr_stack_->bottom, expr); + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + switch (ffeexpr_context_outer_ (ffeexpr_stack_)) + { + case FFEEXPR_contextSFUNCDEF: + case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_: + case FFEEXPR_contextSFUNCDEFINDEX_: + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_: + ctx = FFEEXPR_contextSFUNCDEFACTUALARG_; + break; + + case FFEEXPR_contextSFUNCDEFACTUALARG_: + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + assert ("bad context" == NULL); + ctx = FFEEXPR_context; + break; + + default: + ctx = FFEEXPR_contextACTUALARG_; + break; + } + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx, + ffeexpr_token_arguments_); + + default: + break; + } + + if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT) + && (ffeexpr_stack_->next_dummy != NULL)) + { /* Too few arguments. */ + if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS)) + { + char num[10]; + + sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args); + + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), + ffelex_token_where_column (ffeexpr_stack_->tokens[0])); + ffebad_string (num); + ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter + (ffebld_head (ffeexpr_stack_->next_dummy))))); + ffebad_finish (); + } + for (; + ffeexpr_stack_->next_dummy != NULL; + ffeexpr_stack_->next_dummy + = ffebld_trail (ffeexpr_stack_->next_dummy)) + { + expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0)); + ffebld_set_info (expr, ffeinfo_new_any ()); + ffebld_append_item (&ffeexpr_stack_->bottom, expr); + } + } + + if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT) + && (ffeexpr_stack_->tokens[1] != NULL)) + { /* Too many arguments to statement function. */ + if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS)) + { + char num[10]; + + sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args); + + ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]), + ffelex_token_where_column (ffeexpr_stack_->tokens[1])); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), + ffelex_token_where_column (ffeexpr_stack_->tokens[0])); + ffebad_string (num); + ffebad_finish (); + } + ffelex_token_kill (ffeexpr_stack_->tokens[1]); + } + ffebld_end_list (&ffeexpr_stack_->bottom); + + if (ffebld_op (procedure->u.operand) == FFEBLD_opANY) + { + reduced = ffebld_new_any (); + ffebld_set_info (reduced, ffeinfo_new_any ()); + } + else + { + if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF) + reduced = ffebld_new_funcref (procedure->u.operand, + ffeexpr_stack_->expr); + else + reduced = ffebld_new_subrref (procedure->u.operand, + ffeexpr_stack_->expr); + if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE) + ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]); + else if (ffebld_symter_specific (procedure->u.operand) + != FFEINTRIN_specNONE) + ffeintrin_fulfill_specific (&reduced, &info, &check_intrin, + ffeexpr_stack_->tokens[0]); + else + ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]); + + if (ffebld_op (reduced) != FFEBLD_opANY) + ffebld_set_info (reduced, + ffeinfo_new (ffeinfo_basictype (info), + ffeinfo_kindtype (info), + 0, + FFEINFO_kindENTITY, + FFEINFO_whereFLEETING, + ffeinfo_size (info))); + else + ffebld_set_info (reduced, ffeinfo_new_any ()); + } + if (ffebld_op (reduced) == FFEBLD_opFUNCREF) + reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]); + ffeexpr_stack_->exprstack = procedure->previous; /* Pops + not-quite-operand off + stack. */ + procedure->u.operand = reduced; /* Save the line/column ffewhere + info. */ + ffeexpr_exprstack_push_operand_ (procedure); /* Push it back on stack. */ + if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) + { + ffelex_token_kill (ffeexpr_stack_->tokens[0]); + ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FUNC(3)(1:1)".... */ + + /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where + Z is DOUBLE COMPLEX), and a command-line option doesn't already + establish interpretation, probably complain. */ + + if (check_intrin + && !ffe_is_90 () + && !ffe_is_ugly_complex ()) + { + /* If the outer expression is REAL(me...), issue diagnostic + only if next token isn't the close-paren for REAL(me). */ + + if ((ffeexpr_stack_->previous != NULL) + && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_) + && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL) + && (ffebld_op (reduced) == FFEBLD_opSYMTER) + && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL)) + return (ffelexHandler) ffeexpr_token_intrincheck_; + + /* Diagnose the ambiguity now. */ + + if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG)) + { + ffebad_string (ffeintrin_name_implementation + (ffebld_symter_implementation + (ffebld_left + (ffeexpr_stack_->exprstack->u.operand)))); + ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token), + ffelex_token_where_column (ffeexpr_stack_->exprstack->token)); + ffebad_finish (); + } + } + return (ffelexHandler) ffeexpr_token_substrp_; + } + + if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) + { + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), + ffelex_token_where_column (ffeexpr_stack_->tokens[0])); + ffebad_finish (); + } + ffelex_token_kill (ffeexpr_stack_->tokens[0]); + ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */ + return + (ffelexHandler) ffeexpr_find_close_paren_ (t, + (ffelexHandler) + ffeexpr_token_substrp_); +} + +/* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr + + Return a pointer to this array to the lexer (ffelex), which will + invoke it for the next token. + + Handle expression and COMMA or CLOSE_PAREN. */ + +static ffelexHandler +ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + ffeexprExpr_ array; + ffebld reduced; + ffeinfo info; + ffeinfoWhere where; + ffetargetIntegerDefault val; + ffetargetIntegerDefault lval = 0; + ffetargetIntegerDefault uval = 0; + ffebld lbound; + ffebld ubound; + bool lcheck; + bool ucheck; + + array = ffeexpr_stack_->exprstack; + info = ffebld_info (array->u.operand); + + if ((expr == NULL) /* && ((ffeexpr_stack_->rank != 0) || + (ffelex_token_type(t) == + FFELEX_typeCOMMA)) */ ) + { + if (ffebad_start (FFEBAD_NULL_ELEMENT)) + { + ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), + ffelex_token_where_column (ffeexpr_stack_->tokens[0])); + ffebad_here (1, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_finish (); + } + if (ffeexpr_stack_->rank < ffeinfo_rank (info)) + { /* Don't bother if we're going to complain + later! */ + expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1)); + ffebld_set_info (expr, ffeinfo_new_any ()); + } + } + + if (expr == NULL) + ; + else if (ffeinfo_rank (info) == 0) + { /* In EQUIVALENCE context, ffeinfo_rank(info) + may == 0. */ + ++ffeexpr_stack_->rank; /* Track anyway, may need for new VXT + feature. */ + ffebld_append_item (&ffeexpr_stack_->bottom, expr); + } + else + { + ++ffeexpr_stack_->rank; + if (ffeexpr_stack_->rank > ffeinfo_rank (info)) + { /* Report later which was the first extra + element. */ + if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1) + ffeexpr_stack_->tokens[1] = ffelex_token_use (ft); + } + else + { + switch (ffeinfo_where (ffebld_info (expr))) + { + case FFEINFO_whereCONSTANT: + break; + + case FFEINFO_whereIMMEDIATE: + ffeexpr_stack_->constant = FALSE; + break; + + default: + ffeexpr_stack_->constant = FALSE; + ffeexpr_stack_->immediate = FALSE; + break; + } + if (ffebld_op (expr) == FFEBLD_opCONTER) + { + val = ffebld_constant_integerdefault (ffebld_conter (expr)); + + lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list)); + if (lbound == NULL) + { + lcheck = TRUE; + lval = 1; + } + else if (ffebld_op (lbound) == FFEBLD_opCONTER) + { + lcheck = TRUE; + lval = ffebld_constant_integerdefault (ffebld_conter (lbound)); + } + else + lcheck = FALSE; + + ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list)); + assert (ubound != NULL); + if (ffebld_op (ubound) == FFEBLD_opCONTER) + { + ucheck = TRUE; + uval = ffebld_constant_integerdefault (ffebld_conter (ubound)); + } + else + ucheck = FALSE; + + if ((lcheck && (val < lval)) || (ucheck && (val > uval))) + { + ffebad_start (FFEBAD_RANGE_ARRAY); + ffebad_here (0, ffelex_token_where_line (ft), + ffelex_token_where_column (ft)); + ffebad_finish (); + } + } + ffebld_append_item (&ffeexpr_stack_->bottom, expr); + ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list); + } + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + switch (ffeexpr_context_outer_ (ffeexpr_stack_)) + { + case FFEEXPR_contextDATAIMPDOITEM_: + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextDATAIMPDOINDEX_, + ffeexpr_token_elements_); + + case FFEEXPR_contextEQUIVALENCE: + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextEQVINDEX_, + ffeexpr_token_elements_); + + case FFEEXPR_contextSFUNCDEF: + case FFEEXPR_contextSFUNCDEFINDEX_: + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextSFUNCDEFINDEX_, + ffeexpr_token_elements_); + + case FFEEXPR_contextSFUNCDEFACTUALARG_: + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + assert ("bad context" == NULL); + break; + + default: + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextINDEX_, + ffeexpr_token_elements_); + } + + default: + break; + } + + if ((ffeexpr_stack_->rank != ffeinfo_rank (info)) + && (ffeinfo_rank (info) != 0)) + { + char num[10]; + + if (ffeexpr_stack_->rank < ffeinfo_rank (info)) + { + if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS)) + { + sprintf (num, "%d", + (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank)); + + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_here (1, + ffelex_token_where_line (ffeexpr_stack_->tokens[0]), + ffelex_token_where_column (ffeexpr_stack_->tokens[0])); + ffebad_string (num); + ffebad_finish (); + } + } + else + { + if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS)) + { + sprintf (num, "%d", + (int) (ffeexpr_stack_->rank - ffeinfo_rank (info))); + + ffebad_here (0, + ffelex_token_where_line (ffeexpr_stack_->tokens[1]), + ffelex_token_where_column (ffeexpr_stack_->tokens[1])); + ffebad_here (1, + ffelex_token_where_line (ffeexpr_stack_->tokens[0]), + ffelex_token_where_column (ffeexpr_stack_->tokens[0])); + ffebad_string (num); + ffebad_finish (); + } + ffelex_token_kill (ffeexpr_stack_->tokens[1]); + } + while (ffeexpr_stack_->rank++ < ffeinfo_rank (info)) + { + expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1)); + ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, + 0, FFEINFO_kindENTITY, + FFEINFO_whereCONSTANT, + FFETARGET_charactersizeNONE)); + ffebld_append_item (&ffeexpr_stack_->bottom, expr); + } + } + ffebld_end_list (&ffeexpr_stack_->bottom); + + if (ffebld_op (array->u.operand) == FFEBLD_opANY) + { + reduced = ffebld_new_any (); + ffebld_set_info (reduced, ffeinfo_new_any ()); + } + else + { + reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr); + if (ffeexpr_stack_->constant) + where = FFEINFO_whereFLEETING_CADDR; + else if (ffeexpr_stack_->immediate) + where = FFEINFO_whereFLEETING_IADDR; + else + where = FFEINFO_whereFLEETING; + ffebld_set_info (reduced, + ffeinfo_new (ffeinfo_basictype (info), + ffeinfo_kindtype (info), + 0, + FFEINFO_kindENTITY, + where, + ffeinfo_size (info))); + reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]); + } + + ffeexpr_stack_->exprstack = array->previous; /* Pops not-quite-operand off + stack. */ + array->u.operand = reduced; /* Save the line/column ffewhere info. */ + ffeexpr_exprstack_push_operand_ (array); /* Push it back on stack. */ + + switch (ffeinfo_basictype (info)) + { + case FFEINFO_basictypeCHARACTER: + ffeexpr_is_substr_ok_ = TRUE; /* Everyone likes "FOO(3)(1:1)".... */ + break; + + case FFEINFO_basictypeNONE: + ffeexpr_is_substr_ok_ = TRUE; + assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE); + break; + + default: + ffeexpr_is_substr_ok_ = FALSE; + break; + } + + if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) + { + ffelex_token_kill (ffeexpr_stack_->tokens[0]); + return (ffelexHandler) ffeexpr_token_substrp_; + } + + if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) + { + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), + ffelex_token_where_column (ffeexpr_stack_->tokens[0])); + ffebad_finish (); + } + ffelex_token_kill (ffeexpr_stack_->tokens[0]); + return + (ffelexHandler) ffeexpr_find_close_paren_ (t, + (ffelexHandler) + ffeexpr_token_substrp_); +} + +/* ffeexpr_token_equivalence_ -- OPEN_PAREN expr + + Return a pointer to this array to the lexer (ffelex), which will + invoke it for the next token. + + If token is COLON, pass off to _substr_, else init list and pass off + to _elements_. This handles the case "EQUIVALENCE (FOO(expr?", where + ? marks the token, and where FOO's rank/type has not yet been established, + meaning we could be in a list of indices or in a substring + specification. */ + +static ffelexHandler +ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + if (ffelex_token_type (t) == FFELEX_typeCOLON) + return ffeexpr_token_substring_ (ft, expr, t); + + ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); + return ffeexpr_token_elements_ (ft, expr, t); +} + +/* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Handle expression (which may be null) and COLON. */ + +static ffelexHandler +ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + ffeexprExpr_ string; + ffeinfo info; + ffetargetIntegerDefault i; + ffeexprContext ctx; + ffetargetCharacterSize size; + + string = ffeexpr_stack_->exprstack; + info = ffebld_info (string->u.operand); + size = ffebld_size_max (string->u.operand); + + if (ffelex_token_type (t) == FFELEX_typeCOLON) + { + if ((expr != NULL) + && (ffebld_op (expr) == FFEBLD_opCONTER) + && (((i = ffebld_constant_integerdefault (ffebld_conter (expr))) + < 1) + || ((size != FFETARGET_charactersizeNONE) && (i > size)))) + { + ffebad_start (FFEBAD_RANGE_SUBSTR); + ffebad_here (0, ffelex_token_where_line (ft), + ffelex_token_where_column (ft)); + ffebad_finish (); + } + ffeexpr_stack_->expr = expr; + + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextSFUNCDEF: + case FFEEXPR_contextSFUNCDEFINDEX_: + ctx = FFEEXPR_contextSFUNCDEFINDEX_; + break; + + case FFEEXPR_contextSFUNCDEFACTUALARG_: + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + assert ("bad context" == NULL); + ctx = FFEEXPR_context; + break; + + default: + ctx = FFEEXPR_contextINDEX_; + break; + } + + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx, + ffeexpr_token_substring_1_); + } + + if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR)) + { + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), + ffelex_token_where_column (ffeexpr_stack_->tokens[0])); + ffebad_finish (); + } + + ffeexpr_stack_->expr = NULL; + return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t); +} + +/* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + Handle expression (which might be null) and CLOSE_PAREN. */ + +static ffelexHandler +ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t) +{ + ffeexprExpr_ string; + ffebld reduced; + ffebld substrlist; + ffebld first = ffeexpr_stack_->expr; + ffebld strop; + ffeinfo info; + ffeinfoWhere lwh; + ffeinfoWhere rwh; + ffeinfoWhere where; + ffeinfoKindtype first_kt; + ffeinfoKindtype last_kt; + ffetargetIntegerDefault first_val; + ffetargetIntegerDefault last_val; + ffetargetCharacterSize size; + ffetargetCharacterSize strop_size_max; + + string = ffeexpr_stack_->exprstack; + strop = string->u.operand; + info = ffebld_info (strop); + + if ((first == NULL) || (ffebld_op (first) == FFEBLD_opCONTER)) + { /* The starting point is known. */ + first_val = (first == NULL) ? 1 + : ffebld_constant_integerdefault (ffebld_conter (first)); + } + else + { /* Assume start of the entity. */ + first_val = 1; + } + + if ((last != NULL) && (ffebld_op (last) == FFEBLD_opCONTER)) + { /* The ending point is known. */ + last_val = ffebld_constant_integerdefault (ffebld_conter (last)); + + if ((first == NULL) || (ffebld_op (first) == FFEBLD_opCONTER)) + { /* The beginning point is a constant. */ + if (first_val <= last_val) + size = last_val - first_val + 1; + else + { + if (0 && ffe_is_90 ()) + size = 0; + else + { + size = 1; + ffebad_start (FFEBAD_ZERO_SIZE); + ffebad_here (0, ffelex_token_where_line (ft), + ffelex_token_where_column (ft)); + ffebad_finish (); + } + } + } + else + size = FFETARGET_charactersizeNONE; + + strop_size_max = ffebld_size_max (strop); + + if ((strop_size_max != FFETARGET_charactersizeNONE) + && (last_val > strop_size_max)) + { /* Beyond maximum possible end of string. */ + ffebad_start (FFEBAD_RANGE_SUBSTR); + ffebad_here (0, ffelex_token_where_line (ft), + ffelex_token_where_column (ft)); + ffebad_finish (); + } + } + else + size = FFETARGET_charactersizeNONE; /* The size is not known. */ + +#if 0 /* Don't do this, or "is size of target + known?" would no longer be easily + answerable. To see if there is a max + size, use ffebld_size_max; to get only the + known size, else NONE, use + ffebld_size_known; use ffebld_size if + values are sure to be the same (not + opSUBSTR or opCONCATENATE or known to have + known length). By getting rid of this + "useful info" stuff, we don't end up + blank-padding the constant in the + assignment "A(I:J)='XYZ'" to the known + length of A. */ + if (size == FFETARGET_charactersizeNONE) + size = strop_size_max; /* Assume we use the entire string. */ +#endif + + substrlist + = ffebld_new_item + (first, + ffebld_new_item + (last, + NULL + ) + ) + ; + + if (first == NULL) + lwh = FFEINFO_whereCONSTANT; + else + lwh = ffeinfo_where (ffebld_info (first)); + if (last == NULL) + rwh = FFEINFO_whereCONSTANT; + else + rwh = ffeinfo_where (ffebld_info (last)); + + switch (lwh) + { + case FFEINFO_whereCONSTANT: + switch (rwh) + { + case FFEINFO_whereCONSTANT: + where = FFEINFO_whereCONSTANT; + break; + + case FFEINFO_whereIMMEDIATE: + where = FFEINFO_whereIMMEDIATE; + break; + + default: + where = FFEINFO_whereFLEETING; + break; + } + break; + + case FFEINFO_whereIMMEDIATE: + switch (rwh) + { + case FFEINFO_whereCONSTANT: + case FFEINFO_whereIMMEDIATE: + where = FFEINFO_whereIMMEDIATE; + break; + + default: + where = FFEINFO_whereFLEETING; + break; + } + break; + + default: + where = FFEINFO_whereFLEETING; + break; + } + + if (first == NULL) + first_kt = FFEINFO_kindtypeINTEGERDEFAULT; + else + first_kt = ffeinfo_kindtype (ffebld_info (first)); + if (last == NULL) + last_kt = FFEINFO_kindtypeINTEGERDEFAULT; + else + last_kt = ffeinfo_kindtype (ffebld_info (last)); + + switch (where) + { + case FFEINFO_whereCONSTANT: + switch (ffeinfo_where (info)) + { + case FFEINFO_whereCONSTANT: + break; + + case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */ + where = FFEINFO_whereIMMEDIATE; + break; + + default: + where = FFEINFO_whereFLEETING_CADDR; + break; + } + break; + + case FFEINFO_whereIMMEDIATE: + switch (ffeinfo_where (info)) + { + case FFEINFO_whereCONSTANT: + case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */ + break; + + default: + where = FFEINFO_whereFLEETING_IADDR; + break; + } + break; + + default: + switch (ffeinfo_where (info)) + { + case FFEINFO_whereCONSTANT: + where = FFEINFO_whereCONSTANT_SUBOBJECT; /* An F90 concept. */ + break; + + case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */ + default: + where = FFEINFO_whereFLEETING; + break; + } + break; + } + + if (ffebld_op (strop) == FFEBLD_opANY) + { + reduced = ffebld_new_any (); + ffebld_set_info (reduced, ffeinfo_new_any ()); + } + else + { + reduced = ffebld_new_substr (strop, substrlist); + ffebld_set_info (reduced, ffeinfo_new + (FFEINFO_basictypeCHARACTER, + ffeinfo_kindtype (info), + 0, + FFEINFO_kindENTITY, + where, + size)); + reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]); + } + + ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off + stack. */ + string->u.operand = reduced; /* Save the line/column ffewhere info. */ + ffeexpr_exprstack_push_operand_ (string); /* Push it back on stack. */ + + if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) + { + ffelex_token_kill (ffeexpr_stack_->tokens[0]); + ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FOO(3:5)(1:1)".... */ + return (ffelexHandler) ffeexpr_token_substrp_; + } + + if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION)) + { + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]), + ffelex_token_where_column (ffeexpr_stack_->tokens[0])); + ffebad_finish (); + } + + ffelex_token_kill (ffeexpr_stack_->tokens[0]); + ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */ + return + (ffelexHandler) ffeexpr_find_close_paren_ (t, + (ffelexHandler) + ffeexpr_token_substrp_); +} + +/* ffeexpr_token_substrp_ -- Rhs + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and + issue error message if flag (serves as argument) is set. Else, just + forward token to binary_. */ + +static ffelexHandler +ffeexpr_token_substrp_ (ffelexToken t) +{ + ffeexprContext ctx; + + if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN) + return (ffelexHandler) ffeexpr_token_binary_ (t); + + ffeexpr_stack_->tokens[0] = ffelex_token_use (t); + + switch (ffeexpr_stack_->context) + { + case FFEEXPR_contextSFUNCDEF: + case FFEEXPR_contextSFUNCDEFINDEX_: + ctx = FFEEXPR_contextSFUNCDEFINDEX_; + break; + + case FFEEXPR_contextSFUNCDEFACTUALARG_: + case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_: + assert ("bad context" == NULL); + ctx = FFEEXPR_context; + break; + + default: + ctx = FFEEXPR_contextINDEX_; + break; + } + + if (!ffeexpr_is_substr_ok_) + { + if (ffebad_start (FFEBAD_BAD_SUBSTR)) + { + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token), + ffelex_token_where_column (ffeexpr_stack_->exprstack->token)); + ffebad_finish (); + } + + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx, + ffeexpr_token_anything_); + } + + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx, + ffeexpr_token_substring_); +} + +static ffelexHandler +ffeexpr_token_intrincheck_ (ffelexToken t) +{ + if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN) + && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG)) + { + ffebad_string (ffeintrin_name_implementation + (ffebld_symter_implementation + (ffebld_left + (ffeexpr_stack_->exprstack->u.operand)))); + ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token), + ffelex_token_where_column (ffeexpr_stack_->exprstack->token)); + ffebad_finish (); + } + + return (ffelexHandler) ffeexpr_token_substrp_ (t); +} + +/* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr + + Return a pointer to this function to the lexer (ffelex), which will + invoke it for the next token. + + If COLON, do everything we would have done since _parenthesized_ if + we had known NAME represented a kindENTITY instead of a kindFUNCTION. + If not COLON, do likewise for kindFUNCTION instead. */ + +static ffelexHandler +ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + ffeinfoWhere where; + ffesymbol s; + ffesymbolAttrs sa; + ffebld symter = ffeexpr_stack_->exprstack->u.operand; + bool needs_type; + ffeintrinGen gen; + ffeintrinSpec spec; + ffeintrinImp imp; + + s = ffebld_symter (symter); + sa = ffesymbol_attrs (s); + where = ffesymbol_where (s); + + /* We get here only if we don't already know enough about FOO when seeing a + FOO(stuff) reference, and FOO might turn out to be a CHARACTER type. If + "stuff" is a substring reference, then FOO is a CHARACTER scalar type. + Else FOO is a function, either intrinsic or external. If intrinsic, it + wouldn't necessarily be CHARACTER type, so unless it has already been + declared DUMMY, it hasn't had its type established yet. It can't be + CHAR*(*) in any case, though it can have an explicit CHAR*n type. */ + + assert (!(sa & ~(FFESYMBOL_attrsDUMMY + | FFESYMBOL_attrsTYPE))); + + needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY); + + ffesymbol_signal_change (s); /* Probably already done, but in case.... */ + + if (ffelex_token_type (t) == FFELEX_typeCOLON) + { /* Definitely an ENTITY (char substring). */ + if (needs_type && !ffeimplic_establish_symbol (s)) + { + ffesymbol_error (s, ffeexpr_stack_->tokens[0]); + return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t); + } + + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + ffesymbol_rank (s), + FFEINFO_kindENTITY, + (where == FFEINFO_whereNONE) + ? FFEINFO_whereLOCAL + : where, + ffesymbol_size (s))); + ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s))); + + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_resolve_intrin (s); + s = ffecom_sym_learned (s); + ffesymbol_signal_unreported (s); /* For debugging purposes. */ + + ffeexpr_stack_->exprstack->u.operand + = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]); + + return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t); + } + + /* The "stuff" isn't a substring notation, so we now know the overall + reference is to a function. */ + + if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0], + FALSE, &gen, &spec, &imp)) + { + ffebld_symter_set_generic (symter, gen); + ffebld_symter_set_specific (symter, spec); + ffebld_symter_set_implementation (symter, imp); + ffesymbol_set_generic (s, gen); + ffesymbol_set_specific (s, spec); + ffesymbol_set_implementation (s, imp); + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + 0, + FFEINFO_kindFUNCTION, + FFEINFO_whereINTRINSIC, + ffesymbol_size (s))); + } + else + { /* Not intrinsic, now needs CHAR type. */ + if (!ffeimplic_establish_symbol (s)) + { + ffesymbol_error (s, ffeexpr_stack_->tokens[0]); + return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t); + } + + ffesymbol_set_info (s, + ffeinfo_new (ffesymbol_basictype (s), + ffesymbol_kindtype (s), + ffesymbol_rank (s), + FFEINFO_kindFUNCTION, + (where == FFEINFO_whereNONE) + ? FFEINFO_whereGLOBAL + : where, + ffesymbol_size (s))); + } + + ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s))); + + ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD); + ffesymbol_resolve_intrin (s); + s = ffecom_sym_learned (s); + ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE); + ffesymbol_signal_unreported (s); /* For debugging purposes. */ + ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom); + return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t); +} + +/* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr + + Handle basically any expression, looking for CLOSE_PAREN. */ + +static ffelexHandler +ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED, + ffelexToken t) +{ + ffeexprExpr_ e = ffeexpr_stack_->exprstack; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLON: + return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, + FFEEXPR_contextACTUALARG_, + ffeexpr_token_anything_); + + default: + e->u.operand = ffebld_new_any (); + ffebld_set_info (e->u.operand, ffeinfo_new_any ()); + ffelex_token_kill (ffeexpr_stack_->tokens[0]); + ffeexpr_is_substr_ok_ = FALSE; + if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN) + return (ffelexHandler) ffeexpr_token_substrp_; + return (ffelexHandler) ffeexpr_token_substrp_ (t); + } +} + +/* Terminate module. */ + +void +ffeexpr_terminate_2 () +{ + assert (ffeexpr_stack_ == NULL); + assert (ffeexpr_level_ == 0); +} diff --git a/gcc/f/expr.h b/gcc/f/expr.h new file mode 100644 index 000000000000..db7d9fa78e7f --- /dev/null +++ b/gcc/f/expr.h @@ -0,0 +1,194 @@ +/* expr.h -- Public #include File (module.h template V1.0) + Copyright (C) 1995, 1996 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + expr.c + + Modifications: +*/ + +/* Allow multiple inclusion to work. */ + +#ifndef _H_f_expr +#define _H_f_expr + +/* Simple definitions and enumerations. */ + +typedef enum + { + FFEEXPR_contextLET, + FFEEXPR_contextASSIGN, + FFEEXPR_contextIOLIST, + FFEEXPR_contextPARAMETER, + FFEEXPR_contextSUBROUTINEREF, + FFEEXPR_contextDATA, + FFEEXPR_contextIF, + FFEEXPR_contextARITHIF, + FFEEXPR_contextDO, + FFEEXPR_contextDOWHILE, + FFEEXPR_contextFORMAT, + FFEEXPR_contextAGOTO, + FFEEXPR_contextCGOTO, + FFEEXPR_contextCHARACTERSIZE, + FFEEXPR_contextEQUIVALENCE, + FFEEXPR_contextSTOP, + FFEEXPR_contextRETURN, + FFEEXPR_contextSFUNCDEF, + FFEEXPR_contextINCLUDE, + FFEEXPR_contextWHERE, + FFEEXPR_contextSELECTCASE, + FFEEXPR_contextCASE, + FFEEXPR_contextDIMLIST, + FFEEXPR_contextDIMLISTCOMMON, /* Dim list in COMMON stmt. */ + FFEEXPR_contextFILEASSOC, /* ASSOCIATEVARIABLE=. */ + FFEEXPR_contextFILEINT, /* IOSTAT=. */ + FFEEXPR_contextFILEDFINT, /* NEXTREC=. */ + FFEEXPR_contextFILELOG, /* NAMED=. */ + FFEEXPR_contextFILENUM, /* Numerical expression. */ + FFEEXPR_contextFILECHAR, /* Character expression. */ + FFEEXPR_contextFILENUMCHAR, /* READ KEYxyz=. */ + FFEEXPR_contextFILEDFCHAR, /* Default kind character expression. */ + FFEEXPR_contextFILEKEY, /* OPEN KEY=. */ + FFEEXPR_contextFILEEXTFUNC, /* USEROPEN=. */ + FFEEXPR_contextFILEUNIT, /* READ/WRITE UNIT=. */ + FFEEXPR_contextFILEUNIT_DF, /* DEFINE FILE unit (no "(" after it). */ + FFEEXPR_contextFILEFORMATNML, /* [FMT=] or [NML=]. */ + FFEEXPR_contextFILEFORMAT, /* FMT=. */ + FFEEXPR_contextFILENAMELIST,/* NML=. */ + FFEEXPR_contextFILENUMAMBIG,/* BACKSPACE, ENDFILE, REWIND, UNLOCK... + where at e.g. BACKSPACE(, if COMMA seen + before ), it is ok. */ + FFEEXPR_contextFILEUNITAMBIG, /* READ(, if COMMA seen before ), ok. */ + FFEEXPR_contextFILEVXTCODE, /* ENCODE/DECODE third arg (scalar/array). */ + FFEEXPR_contextALLOCATE, /* ALLOCATE objects (weird). */ + FFEEXPR_contextDEALLOCATE, /* DEALLOCATE objects (weird). */ + FFEEXPR_contextHEAPSTAT, /* ALLOCATE/DEALLOCATE STAT= variable. */ + FFEEXPR_contextKINDTYPE, /* KIND=. */ + FFEEXPR_contextINITVAL, /* R426 =initialization-expr. */ + FFEEXPR_contextNULLIFY, /* Pointer names only (F90) or pointers. */ + FFEEXPR_contextIOLISTDF, /* IOLIST w/internal file (V112 9-14 30,31). */ + FFEEXPR_contextINDEX_, /* Element dimension or substring value. */ + FFEEXPR_contextEQVINDEX_, /* EQUIVALENCE element dimension. */ + FFEEXPR_contextDATAIMPDOINDEX_, /* INDEX in DATAIMPDO context. */ + FFEEXPR_contextIMPDOITEM_, + FFEEXPR_contextIMPDOITEMDF_,/* to ...ITEM_ as IOLISTDF is to IOLIST. */ + FFEEXPR_contextIMPDOCTRL_, + FFEEXPR_contextDATAIMPDOITEM_, + FFEEXPR_contextDATAIMPDOCTRL_, + FFEEXPR_contextLOC_, + FFEEXPR_contextACTUALARG_, /* Actual arg to function or subroutine; + turns into ACTUALARGEXPR_ if tokens not + NAME (CLOSE_PAREN/COMMA) or PERCENT.... */ + FFEEXPR_contextACTUALARGEXPR_, /* Like LET but disallow CHAR*(*) + concats. */ + FFEEXPR_contextINDEXORACTUALARG_, /* "CHARACTER FOO; PRINT *,FOO(?". */ + FFEEXPR_contextINDEXORACTUALARGEXPR_, /* ? not NAME + (CLOSE_PAREN/COMMA). */ + FFEEXPR_contextSFUNCDEFINDEX_, /* INDEX_ within stmt-func def. */ + FFEEXPR_contextSFUNCDEFACTUALARG_, + FFEEXPR_contextSFUNCDEFACTUALARGEXPR_, + FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_, + FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_, + FFEEXPR_contextPAREN_, /* Rhs paren except in LET context. */ + FFEEXPR_contextPARENFILENUM_, /* Either PAREN or FILENUM context. */ + FFEEXPR_contextPARENFILEUNIT_, /* Either PAREN or FILEUNIT context. */ + FFEEXPR_context + } ffeexprContext; + +/* Typedefs. */ + + +/* Include files needed by this one. */ + +#include "bld.h" +#include "lex.h" +#include "malloc.h" + +/* Structure definitions. */ + +typedef ffelexHandler (*ffeexprCallback) (ffelexToken ft, ffebld expr, + ffelexToken t); + +/* Global objects accessed by users of this module. */ + + +/* Declare functions with prototypes. */ + +ffebld ffeexpr_collapse_convert (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_paren (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_uplus (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_uminus (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_not (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_add (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_subtract (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_multiply (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_divide (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_power (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_lt (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_le (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_eq (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_ne (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_gt (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_ge (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_and (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_or (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_xor (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_eqv (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_neqv (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_symter (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_funcref (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t); +ffebld ffeexpr_collapse_substr (ffebld expr, ffelexToken t); +ffebld ffeexpr_convert (ffebld source, ffelexToken source_token, + ffelexToken dest_token, ffeinfoBasictype bt, ffeinfoKindtype kt, + ffeinfoRank rk, ffetargetCharacterSize sz, + ffeexprContext context); +ffebld ffeexpr_convert_expr (ffebld source, ffelexToken source_token, + ffebld dest, ffelexToken dest_token, + ffeexprContext context); +ffebld ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token, + ffesymbol dest, ffelexToken dest_token); +void ffeexpr_init_2 (void); +ffelexHandler ffeexpr_rhs (mallocPool pool, ffeexprContext context, + ffeexprCallback callback); +ffelexHandler ffeexpr_lhs (mallocPool pool, ffeexprContext context, + ffeexprCallback callback); +void ffeexpr_terminate_2 (void); +void ffeexpr_type_combine (ffeinfoBasictype *nbt, ffeinfoKindtype *nkt, + ffeinfoBasictype lbt, ffeinfoKindtype lkt, + ffeinfoBasictype rbt, ffeinfoKindtype rkt, + ffelexToken t); + +/* Define macros. */ + +#define ffeexpr_init_0() +#define ffeexpr_init_1() +#define ffeexpr_init_3() +#define ffeexpr_init_4() +#define ffeexpr_terminate_0() +#define ffeexpr_terminate_1() +#define ffeexpr_terminate_3() +#define ffeexpr_terminate_4() + +/* End of #include file. */ + +#endif diff --git a/gcc/f/fini.c b/gcc/f/fini.c new file mode 100644 index 000000000000..6e324b64602d --- /dev/null +++ b/gcc/f/fini.c @@ -0,0 +1,774 @@ +/* fini.c + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. */ + +#include "proj.h" +#include +#include "malloc.h" + +#define MAXNAMELEN 100 + +typedef struct _name_ *name; + +struct _name_ + { + name next; + name previous; + name next_alpha; + name previous_alpha; + int namelen; + int kwlen; + char kwname[MAXNAMELEN]; + char name_uc[MAXNAMELEN]; + char name_lc[MAXNAMELEN]; + char name_ic[MAXNAMELEN]; + }; + +struct _name_root_ + { + name first; + name last; + }; + +struct _name_alpha_ + { + name ign1; + name ign2; + name first; + name last; + }; + +static FILE *in; +static FILE *out; +static char prefix[32]; +static char postfix[32]; +static char storage[32]; +static char *spaces[] += +{ + "", /* 0 */ + " ", /* 1 */ + " ", /* 2 */ + " ", /* 3 */ + " ", /* 4 */ + " ", /* 5 */ + " ", /* 6 */ + " ", /* 7 */ + "\t", /* 8 */ + "\t ", /* 9 */ + "\t ", /* 10 */ + "\t ", /* 11 */ + "\t ", /* 12 */ + "\t ", /* 13 */ + "\t ", /* 14 */ + "\t ", /* 15 */ + "\t\t", /* 16 */ + "\t\t ", /* 17 */ + "\t\t ", /* 18 */ + "\t\t ", /* 19 */ + "\t\t ", /* 20 */ + "\t\t ", /* 21 */ + "\t\t ", /* 22 */ + "\t\t ", /* 23 */ + "\t\t\t", /* 24 */ + "\t\t\t ", /* 25 */ + "\t\t\t ", /* 26 */ + "\t\t\t ", /* 27 */ + "\t\t\t ", /* 28 */ + "\t\t\t ", /* 29 */ + "\t\t\t ", /* 30 */ + "\t\t\t ", /* 31 */ + "\t\t\t\t", /* 32 */ + "\t\t\t\t ", /* 33 */ + "\t\t\t\t ", /* 34 */ + "\t\t\t\t ", /* 35 */ + "\t\t\t\t ", /* 36 */ + "\t\t\t\t ", /* 37 */ + "\t\t\t\t ", /* 38 */ + "\t\t\t\t ", /* 39 */ + "\t\t\t\t\t", /* 40 */ + "\t\t\t\t\t ", /* 41 */ + "\t\t\t\t\t ", /* 42 */ + "\t\t\t\t\t ", /* 43 */ + "\t\t\t\t\t ", /* 44 */ + "\t\t\t\t\t ", /* 45 */ + "\t\t\t\t\t ", /* 46 */ + "\t\t\t\t\t ", /* 47 */ + "\t\t\t\t\t\t", /* 48 */ + "\t\t\t\t\t\t ", /* 49 */ + "\t\t\t\t\t\t ", /* 50 */ + "\t\t\t\t\t\t ", /* 51 */ + "\t\t\t\t\t\t ", /* 52 */ + "\t\t\t\t\t\t ", /* 53 */ + "\t\t\t\t\t\t ", /* 54 */ + "\t\t\t\t\t\t ", /* 55 */ + "\t\t\t\t\t\t\t", /* 56 */ + "\t\t\t\t\t\t\t ", /* 57 */ + "\t\t\t\t\t\t\t ", /* 58 */ + "\t\t\t\t\t\t\t ", /* 59 */ + "\t\t\t\t\t\t\t ", /* 60 */ + "\t\t\t\t\t\t\t ", /* 61 */ + "\t\t\t\t\t\t\t ", /* 62 */ + "\t\t\t\t\t\t\t ", /* 63 */ + "\t\t\t\t\t\t\t\t", /* 64 */ + "\t\t\t\t\t\t\t\t ", /* 65 */ + "\t\t\t\t\t\t\t\t ", /* 66 */ + "\t\t\t\t\t\t\t\t ", /* 67 */ + "\t\t\t\t\t\t\t\t ", /* 68 */ + "\t\t\t\t\t\t\t\t ", /* 69 */ + "\t\t\t\t\t\t\t\t ", /* 70 */ + "\t\t\t\t\t\t\t\t ", /* 71 */ + "\t\t\t\t\t\t\t\t\t", /* 72 */ + "\t\t\t\t\t\t\t\t\t ", /* 73 */ + "\t\t\t\t\t\t\t\t\t ", /* 74 */ + "\t\t\t\t\t\t\t\t\t ", /* 75 */ + "\t\t\t\t\t\t\t\t\t ", /* 76 */ + "\t\t\t\t\t\t\t\t\t ", /* 77 */ + "\t\t\t\t\t\t\t\t\t ", /* 78 */ + "\t\t\t\t\t\t\t\t\t ", /* 79 */ + "\t\t\t\t\t\t\t\t\t\t", /* 80 */ + "\t\t\t\t\t\t\t\t\t\t ", /* 81 */ + "\t\t\t\t\t\t\t\t\t\t ", /* 82 */ + "\t\t\t\t\t\t\t\t\t\t ", /* 83 */ + "\t\t\t\t\t\t\t\t\t\t ", /* 84 */ + "\t\t\t\t\t\t\t\t\t\t ", /* 85 */ + "\t\t\t\t\t\t\t\t\t\t ", /* 86 */ + "\t\t\t\t\t\t\t\t\t\t ",/* 87 */ + "\t\t\t\t\t\t\t\t\t\t\t", /* 88 */ + "\t\t\t\t\t\t\t\t\t\t\t ", /* 89 */ + "\t\t\t\t\t\t\t\t\t\t\t ", /* 90 */ + "\t\t\t\t\t\t\t\t\t\t\t ", /* 91 */ + "\t\t\t\t\t\t\t\t\t\t\t ", /* 92 */ + "\t\t\t\t\t\t\t\t\t\t\t ",/* 93 */ + "\t\t\t\t\t\t\t\t\t\t\t ", /* 94 */ + "\t\t\t\t\t\t\t\t\t\t\t ", /* 95 */ + "\t\t\t\t\t\t\t\t\t\t\t\t", /* 96 */ + "\t\t\t\t\t\t\t\t\t\t\t\t ", /* 97 */ + "\t\t\t\t\t\t\t\t\t\t\t\t ", /* 98 */ + "\t\t\t\t\t\t\t\t\t\t\t\t ",/* 99 */ + "\t\t\t\t\t\t\t\t\t\t\t\t ", /* 100 */ + "\t\t\t\t\t\t\t\t\t\t\t\t ", /* 101 */ + "\t\t\t\t\t\t\t\t\t\t\t\t ", /* 102 */ + "\t\t\t\t\t\t\t\t\t\t\t\t ", /* 103 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t", /* 104 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t ",/* 105 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 106 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 107 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 108 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 109 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 110 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 111 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t", /* 112 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 113 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 114 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 115 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 116 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 117 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 118 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 119 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t", /* 120 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 121 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 122 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 123 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 124 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 125 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 126 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 127 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t", /* 128 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 129 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 130 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 131 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 132 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 133 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 134 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 135 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t", /* 136 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 137 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 138 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 139 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 140 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 141 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 142 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 143 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t", /* 144 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 145 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 146 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 147 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 148 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 149 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 150 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 151 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t", /* 152 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 153 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 154 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 155 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 156 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 157 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 158 */ + "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ", /* 159 */ +}; + +void testname (bool nested, int indent, name first, name last); +void testnames (bool nested, int indent, int len, name first, name last); + +void +main (int argc, char **argv) +{ + char buf[MAXNAMELEN]; + char last_buf[MAXNAMELEN] = ""; + char kwname[MAXNAMELEN]; + char routine[32]; + char type[32]; + int i; + int count; + int len; + struct _name_root_ names[200]; + struct _name_alpha_ names_alpha; + name n; + name newname; + char *input_name; + char *output_name; + char *include_name; + FILE *incl; + int fixlengths; + int total_length; + int do_name; /* TRUE if token may be NAME. */ + int do_names; /* TRUE if token may be NAMES. */ + int cc; + bool do_exit = FALSE; + + for (i = 0; ((size_t) i) < ARRAY_SIZE (names); ++i) + { /* Initialize length/name ordered list roots. */ + names[i].first = (name) &names[i]; + names[i].last = (name) &names[i]; + } + names_alpha.first = (name) &names_alpha; /* Initialize name order. */ + names_alpha.last = (name) &names_alpha; + + if (argc != 4) + { + fprintf (stderr, "Command form: fini input output-code output-include\n"); + exit (1); + } + + input_name = argv[1]; + output_name = argv[2]; + include_name = argv[3]; + + in = fopen (input_name, "r"); + if (in == NULL) + { + fprintf (stderr, "Cannot open \"%s\"\n", input_name); + exit (1); + } + out = fopen (output_name, "w"); + if (out == NULL) + { + fclose (in); + fprintf (stderr, "Cannot open \"%s\"\n", output_name); + exit (1); + } + incl = fopen (include_name, "w"); + if (incl == NULL) + { + fclose (in); + fprintf (stderr, "Cannot open \"%s\"\n", include_name); + exit (1); + } + + /* Get past the initial block-style comment (man, this parsing code is just + _so_ lame, but I'm too lazy to improve it). */ + + for (;;) + { + cc = getc (in); + if (cc == '{') + { + while (((cc = getc (in)) != '}') && (cc != EOF)) + ; + } + else if (cc != EOF) + { + while (((cc = getc (in)) != EOF) && (!isalnum (cc))) + ; + ungetc (cc, in); + break; + } + else + { + assert ("EOF too soon!" == NULL); + exit (1); + } + } + + fscanf (in, "%s %s %s %s %s %d %d", prefix, postfix, storage, type, routine, + &do_name, &do_names); + + if (storage[0] == '\0') + storage[1] = '\0'; + else + /* Assume string is quoted somehow, replace ending quote with space. */ + { + if (storage[2] == '\0') + storage[1] = '\0'; + else + storage[strlen (storage) - 1] = ' '; + } + + if (postfix[0] == '\0') + postfix[1] = '\0'; + else /* Assume string is quoted somehow, strip off + ending quote. */ + postfix[strlen (postfix) - 1] = '\0'; + + for (i = 1; storage[i] != '\0'; ++i) + storage[i - 1] = storage[i]; + storage[i - 1] = '\0'; + + for (i = 1; postfix[i] != '\0'; ++i) + postfix[i - 1] = postfix[i]; + postfix[i - 1] = '\0'; + + fixlengths = strlen (prefix) + strlen (postfix); + + while (TRUE) + { + count = fscanf (in, "%s %s", buf, kwname); + if (count == EOF) + break; + len = strlen (buf); + if (len == 0) + continue; /* Skip empty lines. */ + if (buf[0] == ';') + continue; /* Skip commented-out lines. */ + for (i = strlen (buf) - 1; i > 0; --i) + cc = buf[i]; + + /* Make new name object to store name and its keyword. */ + + newname = (name) malloc (sizeof (*newname)); + newname->namelen = strlen (buf); + newname->kwlen = strlen (kwname); + total_length = newname->kwlen + fixlengths; + if (total_length >= 32) /* Else resulting keyword name too long. */ + { + fprintf (stderr, "%s: %s%s%s is 31+%d chars long\n", input_name, + prefix, kwname, postfix, total_length - 31); + do_exit = TRUE; + } + strcpy (newname->kwname, kwname); + for (i = 0; i < newname->namelen; ++i) + { + cc = buf[i]; + if (isascii (cc) && isalpha (cc)) + { + newname->name_uc[i] = toupper (cc); + newname->name_lc[i] = tolower (cc); + newname->name_ic[i] = cc; + } + else + newname->name_uc[i] = newname->name_lc[i] = newname->name_ic[i] + = cc; + } + newname->name_uc[i] = newname->name_lc[i] = newname->name_ic[i] = '\0'; + + /* Warn user if names aren't alphabetically ordered. */ + + if ((last_buf[0] != '\0') + && (strcmp (last_buf, newname->name_uc) >= 0)) + { + fprintf (stderr, "%s: \"%s\" precedes \"%s\"\n", input_name, + last_buf, newname->name_uc); + do_exit = TRUE; + } + strcpy (last_buf, newname->name_uc); + + /* Append name to end of alpha-sorted list (assumes names entered in + alpha order wrt name, not kwname, even though kwname is output from + this list). */ + + n = names_alpha.last; + newname->next_alpha = n->next_alpha; + newname->previous_alpha = n; + n->next_alpha->previous_alpha = newname; + n->next_alpha = newname; + + /* Insert name in appropriate length/name ordered list. */ + + n = (name) &names[len]; + while ((n->next != (name) &names[len]) + && (strcmp (buf, n->next->name_uc) > 0)) + n = n->next; + if (strcmp (buf, n->next->name_uc) == 0) + { + fprintf (stderr, "%s: extraneous \"%s\"\n", input_name, buf); + do_exit = TRUE; + } + newname->next = n->next; + newname->previous = n; + n->next->previous = newname; + n->next = newname; + } + +#if 0 + for (len = 0; len < ARRAY_SIZE (name); ++len) + { + if (names[len].first == (name) &names[len]) + continue; + printf ("Length %d:\n", len); + for (n = names[len].first; n != (name) &names[len]; n = n->next) + printf (" %s %s %s\n", n->name_uc, n->name_lc, n->name_ic); + } +#endif + + if (do_exit) + exit (1); + + /* First output the #include file. */ + + for (n = names_alpha.first; n != (name) &names_alpha; n = n->next_alpha) + { + fprintf (incl, "#define %sl%s%s %d\n", prefix, n->kwname, postfix, + n->namelen); + } + + fprintf (incl, + "\ +\n\ +enum %s_\n\ +{\n\ +%sNone%s,\n\ +", + type, prefix, postfix); + + for (n = names_alpha.first; n != (name) &names_alpha; n = n->next_alpha) + { + fprintf (incl, + "\ +%s%s%s,\n\ +", + prefix, n->kwname, postfix); + } + + fprintf (incl, + "\ +%s%s\n\ +};\n\ +typedef enum %s_ %s;\n\ +", + prefix, postfix, type, type); + + /* Now output the C program. */ + + fprintf (out, + "\ +%s%s\n\ +%s (ffelexToken t)\n\ +%c\n\ + char *p;\n\ + int c;\n\ +\n\ + p = ffelex_token_text (t);\n\ +\n\ +", + storage, type, routine, '{'); + + if (do_name) + { + if (do_names) + fprintf (out, + "\ + if (ffelex_token_type (t) == FFELEX_typeNAME)\n\ + {\n\ + switch (ffelex_token_length (t))\n\ +\t{\n\ +" + ); + else + fprintf (out, + "\ + assert (ffelex_token_type (t) == FFELEX_typeNAME);\n\ +\n\ + switch (ffelex_token_length (t))\n\ + {\n\ +" + ); + +/* Now output the length as a case, followed by the binary search within that length. */ + + for (len = 0; ((size_t) len) < ARRAY_SIZE (names); ++len) + { + if (names[len].first != (name) &names[len]) + { + if (do_names) + fprintf (out, + "\ +\tcase %d:\n\ +", + len); + else + fprintf (out, + "\ + case %d:\n\ +", + len); + testname (FALSE, do_names ? 10 : 6, names[len].first, names[len].last); + if (do_names) + fprintf (out, + "\ +\t break;\n\ +" + ); + else + fprintf (out, + "\ + break;\n\ +" + ); + } + } + + if (do_names) + fprintf (out, + "\ +\t}\n\ + return %sNone%s;\n\ + }\n\ +\n\ +", + prefix, postfix); + else + fprintf (out, + "\ + }\n\ +\n\ + return %sNone%s;\n\ +}\n\ +", + prefix, postfix); + } + + if (do_names) + { + fputs ("\ + assert (ffelex_token_type (t) == FFELEX_typeNAMES);\n\ +\n\ + switch (ffelex_token_length (t))\n\ + {\n\ + default:\n\ +", + out); + + /* Find greatest non-empty length list. */ + + for (len = ARRAY_SIZE (names) - 1; + names[len].first == (name) &names[len]; + --len) + ; + +/* Now output the length as a case, followed by the binary search within that length. */ + + if (len > 0) + { + for (; len != 0; --len) + { + fprintf (out, + "\ + case %d:\n\ +", + len); + if (names[len].first != (name) &names[len]) + testnames (FALSE, 6, len, names[len].first, names[len].last); + } + if (names[1].first == (name) &names[1]) + fprintf (out, + "\ + ;\n\ +" + ); /* Need empty statement after an empty case + 1: */ + } + + fprintf (out, + "\ + }\n\ +\n\ + return %sNone%s;\n\ +}\n\ +", + prefix, postfix); + } + + if (out != stdout) + fclose (out); + if (incl != stdout) + fclose (incl); + if (in != stdin) + fclose (in); + exit (0); +} + +void +testname (bool nested, int indent, name first, name last) +{ + name n; + name nhalf; + int num; + int numhalf; + + assert (!nested || indent >= 2); + assert (((size_t) indent) + 4 < ARRAY_SIZE (spaces)); + + num = 0; + numhalf = 0; + for (n = first, nhalf = first; n != last->next; n = n->next) + { + if ((++num & 1) == 0) + { + nhalf = nhalf->next; + ++numhalf; + } + } + + if (nested) + fprintf (out, + "\ +%s{\n\ +", + spaces[indent - 2]); + + fprintf (out, + "\ +%sif ((c = ffesrc_strcmp_2c (ffe_case_match (), p, \"%s\", \"%s\", \"%s\")) == 0)\n\ +%sreturn %s%s%s;\n\ +", + spaces[indent], nhalf->name_uc, nhalf->name_lc, nhalf->name_ic, + spaces[indent + 2], prefix, nhalf->kwname, postfix); + + if (num != 1) + { + fprintf (out, + "\ +%selse if (c < 0)\n\ +", + spaces[indent]); + + if (numhalf == 0) + fprintf (out, + "\ +%s;\n\ +", + spaces[indent + 2]); + else + testname (TRUE, indent + 4, first, nhalf->previous); + + if (num - numhalf > 1) + { + fprintf (out, + "\ +%selse\n\ +", + spaces[indent]); + + testname (TRUE, indent + 4, nhalf->next, last); + } + } + + if (nested) + fprintf (out, + "\ +%s}\n\ +", + spaces[indent - 2]); +} + +void +testnames (bool nested, int indent, int len, name first, name last) +{ + name n; + name nhalf; + int num; + int numhalf; + + assert (!nested || indent >= 2); + assert (((size_t) indent) + 4 < ARRAY_SIZE (spaces)); + + num = 0; + numhalf = 0; + for (n = first, nhalf = first; n != last->next; n = n->next) + { + if ((++num & 1) == 0) + { + nhalf = nhalf->next; + ++numhalf; + } + } + + if (nested) + fprintf (out, + "\ +%s{\n\ +", + spaces[indent - 2]); + + fprintf (out, + "\ +%sif ((c = ffesrc_strncmp_2c (ffe_case_match (), p, \"%s\", \"%s\", \"%s\", %d)) == 0)\n\ +%sreturn %s%s%s;\n\ +", + spaces[indent], nhalf->name_uc, nhalf->name_lc, nhalf->name_ic, + len, spaces[indent + 2], prefix, nhalf->kwname, postfix); + + if (num != 1) + { + fprintf (out, + "\ +%selse if (c < 0)\n\ +", + spaces[indent]); + + if (numhalf == 0) + fprintf (out, + "\ +%s;\n\ +", + spaces[indent + 2]); + else + testnames (TRUE, indent + 4, len, first, nhalf->previous); + + if (num - numhalf > 1) + { + fprintf (out, + "\ +%selse\n\ +", + spaces[indent]); + + testnames (TRUE, indent + 4, len, nhalf->next, last); + } + } + + if (nested) + fprintf (out, + "\ +%s}\n\ +", + spaces[indent - 2]); +} diff --git a/gcc/f/flags.j b/gcc/f/flags.j new file mode 100644 index 000000000000..67966b9448ea --- /dev/null +++ b/gcc/f/flags.j @@ -0,0 +1,27 @@ +/* flags.j -- Wrapper for GCC's flags.h + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. */ + +#ifndef MAKING_DEPENDENCIES +#ifndef _J_f_flags +#define _J_f_flags +#include "flags.h" +#endif +#endif diff --git a/gcc/f/g77.1 b/gcc/f/g77.1 new file mode 100644 index 000000000000..fe8b897266f2 --- /dev/null +++ b/gcc/f/g77.1 @@ -0,0 +1,364 @@ +.\" Copyright (c) 1995, 1996 Free Software Foundation -*-Text-*- +.\" See section COPYING for conditions for redistribution +.\" FIXME: no info here on predefines. Should there be? extra for F77... +.TH G77 1 "1997-06-20" "GNU Tools" "GNU Tools" +.de BP +.sp +.ti \-.2i +\(** +.. +.SH NAME +g77 \- GNU project F77 Compiler (v0.5.18) +.SH SYNOPSIS +.RB g77 " [" \c +.IR option " | " "filename " ].\|.\|. +.SH WARNING +The information in this man page is an extract from the full +documentation of the GNU Fortran compiler (version 0.5.18), +and is limited to the meaning of the options. +.PP +This man page is not up to date, since no volunteers want to +maintain it. If you find a discrepancy between the man page and the +software, please check the Info file, which is the authoritative +documentation. +.PP +The version of GNU Fortran documented by the Info file is 0.5.21, +which includes substantial improvements and changes since 0.5.18, +the version documented in this man page. +.PP +If we find that the things in this man page that are out of date cause +significant confusion or complaints, we will stop distributing the man +page. The alternative, updating the man page when we update the Info +file, is impractical because the rest of the work of maintaining GNU Fortran +leaves us no time for that. The GNU project regards man pages as +obsolete and should not let them take time away from other things. +.PP +For complete and current documentation, refer to the Info file `\|\c +.B g77\c +\&\|' or the manual +.I +Using and Porting GNU Fortran (for version 0.5.18)\c +\&. Both are made from the Texinfo source file +.BR g77.texi . +.PP +If your system has the `\|\c +.B info\c +\&\|' command installed, the command `\|\c +.B info g77\c +\&\|' should work, unless +.B g77 +has not been properly installed. +If your system lacks `\|\c +.B info\c +\&\|', or you wish to avoid using it for now, +the command `\|\c +.B more /usr/info/g77.info*\c +\&\|' should work, unless +.B g77 +has not been properly installed. +.PP +If +.B g77 +has not been properly installed, so that you +cannot easily access the Info file for it, +ask your system administrator, or the installer +of +.B g77 +(if you know who that is) to fix the problem. +.SH DESCRIPTION +The C and F77 compilers are integrated; +.B g77 +is a program to call +.B gcc with options to recognize F77. +.B gcc +processes input files +through one or more of four stages: preprocessing, compilation, +assembly, and linking. This man page contains full descriptions for +.I only +F77 specific aspects of the compiler, though it also contains +summaries of some general-purpose options. For a fuller explanation +of the compiler, see +.BR gcc ( 1 ). + +For complete documentation on GNU Fortran, type +.BR info g77 + +F77 source files use the suffix `\|\c +.B .f\c +\&\|'; F77 files to be preprocessed by +.BR cpp ( 1 ) +use the suffix `\|\c +.B .F\c +\&\|'. +.SH OPTIONS +There are many command-line options, including options to control +details of optimization, warnings, and code generation, which are +common to both +.B gcc +and +.B g77\c +\&. For full information on all options, see +.BR gcc ( 1 ). + +Options must be separate: `\|\c +.B \-dr\c +\&\|' is quite different from `\|\c +.B \-d \-r +\&\|'. + +Most `\|\c +.B \-f\c +\&\|' and `\|\c +.B \-W\c +\&\|' options have two contrary forms: +.BI \-f name +and +.BI \-fno\- name\c +\& (or +.BI \-W name +and +.BI \-Wno\- name\c +\&). Only the non-default forms are shown here. + +.TP +.B \-c +Compile or assemble the source files, but do not link. The compiler +output is an object file corresponding to each source file. +.TP +.BI \-D macro +Define macro \c +.I macro\c +\& with the string `\|\c +.B 1\c +\&\|' as its definition. +.TP +.BI \-D macro = defn +Define macro \c +.I macro\c +\& as \c +.I defn\c +\&. +.TP +.BI \-\-driver= command +Specifies that +.IR command , +rather than +.RB ` gcc ', +is to be invoked by +.RB ` g77 ' +to do its job. Example: Within the gcc build directory after building +GNU Fortran (but without having to install it), +.nf + ./g77 \-\-driver=./xgcc -B./ foo.f +.fi +.TP +.B \-E +Stop after the preprocessing stage; do not run the compiler proper. The +output is preprocessed source code, which is sent to the +standard output. +.TP +.B \-g +Produce debugging information in the operating system's native format +(for DBX or SDB or DWARF). GDB also can work with this debugging +information. On most systems that use DBX format, `\|\c +.B \-g\c +\&\|' enables use +of extra debugging information that only GDB can use. + +Unlike most other Fortran compilers, GNU Fortran allows you to use `\|\c +.B \-g\c +\&\|' with +`\|\c +.B \-O\c +\&\|'. The shortcuts taken by optimized code may occasionally +produce surprising results: some variables you declared may not exist +at all; flow of control may briefly move where you did not expect it; +some statements may not be executed because they compute constant +results or their values were already at hand; some statements may +execute in different places because they were moved out of loops. + +Nevertheless it proves possible to debug optimized output. This makes +it reasonable to use the optimizer for programs that might have bugs. +.TP +.BI "\-I" "dir"\c +\& +Append directory \c +.I dir\c +\& to the list of directories searched for include files. +.TP +.BI "\-L" "dir"\c +\& +Add directory \c +.I dir\c +\& to the list of directories to be searched +for `\|\c +.B \-l\c +\&\|'. +.TP +.BI \-l library\c +\& +Use the library named \c +.I library\c +\& when linking. +.TP +.B \-nostdinc +Do not search the standard system directories for header files. Only +the directories you have specified with +.B \-I +options (and the current directory, if appropriate) are searched. +.TP +.B \-O +Optimize. Optimizing compilation takes somewhat more time, and a lot +more memory for a large function. See the GCC documentation for +further optimisation options. Loop unrolling, in particular, may be +worth investigating for typical numerical Fortran programs. +.TP +.BI "\-o " file\c +\& +Place output in file \c +.I file\c +\&. +.TP +.B \-S +Stop after the stage of compilation proper; do not assemble. The output +is an assembler code file for each non-assembler input +file specified. +.TP +.BI \-U macro +Undefine macro \c +.I macro\c +\&. +.TP +.B \-v +Print (on standard error output) the commands executed to run the +stages of compilation. Also print the version number of the compiler +driver program and of the preprocessor and the compiler proper. The +version numbers of g77 itself and the GCC distribution on which it is +based are distinct. Use +.RB ` \-\-driver=true ' +to disable actual invocation of +.RB ` gcc ' +(since +.RB ` true ' +is the name of a UNIX command that simply returns success status). +The command +.RB ` "gcc -v" ' +is the appropriate one to determine the g77 and GCC version numbers; +it will produce an irrelevant error message from +.RB ` ld '. +.TP +.B \-Wall +Issue warnings for conditions which pertain to usage that we recommend +avoiding and that we believe is easy to avoid, even in conjunction +with macros. +.PP + +.SH FILES +.ta \w'LIBDIR/g77\-include 'u +file.h C header (preprocessor) file +.br +file.f Fortran source file +.br +file.for Fortran source file +.br +file.F preprocessed Fortran source file +.br +file.fpp preprocessed Fortran source file +.br +file.s assembly language file +.br +file.o object file +.br +a.out link edited output +.br +\fITMPDIR\fR/cc\(** temporary files +.br +\fILIBDIR\fR/cpp preprocessor +.br +\fILIBDIR\fR/f771 compiler +.br +\fILIBDIR\fR/libf2c.a Fortran run-time library +.br +\fILIBDIR\fR/libgcc.a GCC subroutine library +.br +/lib/crt[01n].o start-up routine +.br +/lib/libc.a standard C library, see +.IR intro (3) +.br +/usr/include standard directory for +.B #include +files +.br +\fILIBDIR\fR/include standard gcc directory for +.B #include +files +.I LIBDIR +is usually +.B /usr/local/lib/\c +.IR machine / version . +.br +.I TMPDIR +comes from the environment variable +.B TMPDIR +(default +.B /usr/tmp +if available, else +.B /tmp\c +\&). +.SH "SEE ALSO" +gcc(1), cpp(1), as(1), ld(1), gdb(1), adb(1), dbx(1), sdb(1). +.br +.RB "`\|" g77 "\|', `\|" gcc "\|', `\|" cpp \|', +.RB `\| as \|', `\| ld \|', +and +.RB `\| gdb \|' +entries in +.B info\c +\&. +.br +.I +Using and Porting GNU Fortran (for version 0.5.18)\c +, James Craig Burley; +.I +Using and Porting GNU CC (for version 2.0)\c +, Richard M. Stallman; +.I +The C Preprocessor\c +, Richard M. Stallman; +.I +Debugging with GDB: the GNU Source-Level Debugger\c +, Richard M. Stallman and Roland H. Pesch; +.I +Using as: the GNU Assembler\c +, Dean Elsner, Jay Fenlason & friends; +.I +gld: the GNU linker\c +, Steve Chamberlain and Roland Pesch. + +.SH BUGS +For instructions on how to report bugs, see the file +.B DOC +in the g77 distribution. + +.SH COPYING +Copyright (c) 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc. +.PP +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. +.PP +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the +entire resulting derived work is distributed under the terms of a +permission notice identical to this one. +.PP +Permission is granted to copy and distribute translations of this +manual into another language, under the above conditions for modified +versions, except that this permission notice may be included in +translations approved by the Free Software Foundation instead of in +the original English. +.SH AUTHORS +See the GNU CC Manual for the contributors to GNU CC. +See the GNU Fortran Manual for the contributors to +GNU Fortran. diff --git a/gcc/f/g77.c b/gcc/f/g77.c new file mode 100644 index 000000000000..0d6f07fae306 --- /dev/null +++ b/gcc/f/g77.c @@ -0,0 +1,1557 @@ +/* G77 preliminary semantic processing for the compiler driver. + Copyright (C) 1993-1997 Free Software Foundation, Inc. + Contributed by Brendan Kehoe (brendan@cygnus.com), with significant + modifications for GNU Fortran by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. */ + +/* This program is a wrapper to the main `gcc' driver. The generic + goal of this program is to be basically identical to gcc (in that + it faithfully passes all of the original arguments to gcc) but, + unless explicitly overridden by the user in certain ways, ensure + that the needs of the language supported by this wrapper are met. + + For GNU Fortran (g77), we do the following to the argument list + before passing it to `gcc': + + 1. Put `-xf77', `-xf77-cpp-input' or `-xratfor' before each list + of foo.f, foo.F or foo.r source files and put `-xnone' after + that list, if necessary. This shouldn't normally be necessary, + but it is done in case gcc.c normally treats .f/.F files as, + say, to be compiled by f2c. + + 2. Make sure `-lf2c -lm' is at the end of the list. + + 3. Make sure each time `-lf2c' or `-lm' is seen, it forms + part of the series `-lf2c -lm'. + + #1 is not done if `-xfoo' is in effect (where foo is not "none"). + #2 and #3 are not done if `-nostdlib' or any option that disables + the linking phase is present, or if `-xfoo' is in effect. Note that + -v by itself disables linking. + + This program was originally made out of gcc/cp/g++.c, but the + way it builds the new argument list was rewritten so it is much + easier to maintain, improve the way it decides to add or not add + extra arguments, etc. And several improvements were made in the + handling of arguments, primarily to make it more consistent with + `gcc' itself. */ + +#ifndef LANGUAGE_F77 +#define LANGUAGE_F77 1 /* Assume f77 language wanted. */ +#endif + +#if LANGUAGE_F77 != 1 +#include + +int +main (argc, argv) + int argc; + char **argv; +{ + fprintf (stderr, "\ +g77: `f77' language not included in list of languages\n\ + built with this installation of gcc.\n"); + exit (1); +} + +#else /* LANGUAGE_F77 == 1 */ +#include "config.j" +#include "zzz.h" +#include +#include + +#ifndef _WIN32 +#include /* May get R_OK, etc. on some systems. */ +#else +#include +#endif + +#ifdef __STDC__ +#include +#else +#include +#endif +#include + +/* Include multi-lib information. */ +#include "multilib.h" + +#ifndef R_OK +#define R_OK 4 +#define W_OK 2 +#define X_OK 1 +#endif + +#ifndef WIFSIGNALED +#define WIFSIGNALED(S) (((S) & 0xff) != 0 && ((S) & 0xff) != 0x7f) +#endif +#ifndef WTERMSIG +#define WTERMSIG(S) ((S) & 0x7f) +#endif +#ifndef WIFEXITED +#define WIFEXITED(S) (((S) & 0xff) == 0) +#endif +#ifndef WEXITSTATUS +#define WEXITSTATUS(S) (((S) & 0xff00) >> 8) +#endif + +/* Defined to the name of the compiler; if using a cross compiler, the + Makefile should compile this file with the proper name + (e.g., "i386-aout-gcc"). */ +#ifndef GCC_NAME +#define GCC_NAME "gcc" +#endif + +/* On MSDOS, write temp files in current dir + because there's no place else we can expect to use. */ +#ifdef __MSDOS__ +#ifndef P_tmpdir +#define P_tmpdir "." +#endif +#ifndef R_OK +#define R_OK 4 +#define W_OK 2 +#define X_OK 1 +#endif +#endif + +/* Add prototype support. */ +#ifndef PROTO +#if defined (USE_PROTOTYPES) ? USE_PROTOTYPES : defined (__STDC__) +#define PROTO(ARGS) ARGS +#else +#define PROTO(ARGS) () +#endif +#endif + +#ifndef VPROTO +#ifdef __STDC__ +#define PVPROTO(ARGS) ARGS +#define VPROTO(ARGS) ARGS +#define VA_START(va_list,var) va_start(va_list,var) +#else +#define PVPROTO(ARGS) () +#define VPROTO(ARGS) (va_alist) va_dcl +#define VA_START(va_list,var) va_start(va_list) +#endif +#endif + +/* Define a generic NULL if one hasn't already been defined. */ + +#ifndef NULL +#define NULL 0 +#endif + +/* Define O_RDONLY if the system hasn't defined it for us. */ +#ifndef O_RDONLY +#define O_RDONLY 0 +#endif + +#ifndef GENERIC_PTR +#if defined (USE_PROTOTYPES) ? USE_PROTOTYPES : defined (__STDC__) +#define GENERIC_PTR void * +#else +#define GENERIC_PTR char * +#endif +#endif + +#ifndef NULL_PTR +#define NULL_PTR ((GENERIC_PTR)0) +#endif + +#ifdef USG +#define vfork fork +#endif /* USG */ + +/* On MSDOS, write temp files in current dir + because there's no place else we can expect to use. */ +#ifdef __MSDOS__ +#ifndef P_tmpdir +#define P_tmpdir "." +#endif +#endif + +/* By default there is no special suffix for executables. */ +#ifndef EXECUTABLE_SUFFIX +#define EXECUTABLE_SUFFIX "" +#endif + +/* By default, colon separates directories in a path. */ +#ifndef PATH_SEPARATOR +#define PATH_SEPARATOR ':' +#endif + +#ifndef DIR_SEPARATOR +#define DIR_SEPARATOR '/' +#endif + +static char dir_separator_str[] = {DIR_SEPARATOR, 0}; + +extern char *getenv (); + +#ifndef errno +extern int errno; +#endif + +extern int sys_nerr; +#ifndef HAVE_STRERROR +#if defined(bsd4_4) +extern const char *const sys_errlist[]; +#else +extern char *sys_errlist[]; +#endif +#else +extern char *strerror(); +#endif + +/* Name with which this program was invoked. */ +static char *programname; + +/* argc, argv from main(). */ +static int xargc; +static char **xargv; + +/* The new argument list will be contained in these, though if identical + to the original list, these will be == xargc, xargv. */ +static int newargc; +static char **newargv; + +/* Options this driver needs to recognize, not just know how to + skip over. */ +typedef enum +{ + OPTION_b, /* Aka --prefix. */ + OPTION_B, /* Aka --target. */ + OPTION_c, /* Aka --compile. */ + OPTION_driver, /* Wrapper-specific option. */ + OPTION_E, /* Aka --preprocess. */ + OPTION_for_linker, /* Aka `-Xlinker' and `-Wl,'. */ + OPTION_help, /* --help. */ + OPTION_i, /* -imacros, -include, -include-*. */ + OPTION_l, + OPTION_L, /* Aka --library-directory. */ + OPTION_M, /* Aka --dependencies. */ + OPTION_MM, /* Aka --user-dependencies. */ + OPTION_nostdlib, /* Aka --no-standard-libraries, or + -nodefaultlibs. */ + OPTION_o, /* Aka --output. */ + OPTION_P, /* Aka --print-*-name. */ + OPTION_S, /* Aka --assemble. */ + OPTION_syntax_only, /* -fsyntax-only. */ + OPTION_v, /* Aka --verbose. */ + OPTION_version, /* --version. */ + OPTION_V, /* Aka --use-version. */ + OPTION_x, /* Aka --language. */ + OPTION_ /* Unrecognized or unimportant. */ +} Option; + +/* THE FOLLOWING COMES STRAIGHT FROM prerelease gcc-2.8.0/gcc.c: */ + +/* This defines which switch letters take arguments. */ + +#define DEFAULT_SWITCH_TAKES_ARG(CHAR) \ + ((CHAR) == 'D' || (CHAR) == 'U' || (CHAR) == 'o' \ + || (CHAR) == 'e' || (CHAR) == 'T' || (CHAR) == 'u' \ + || (CHAR) == 'I' || (CHAR) == 'm' || (CHAR) == 'x' \ + || (CHAR) == 'L' || (CHAR) == 'A') + +#ifndef SWITCH_TAKES_ARG +#define SWITCH_TAKES_ARG(CHAR) DEFAULT_SWITCH_TAKES_ARG(CHAR) +#endif + +/* This defines which multi-letter switches take arguments. */ + +#define DEFAULT_WORD_SWITCH_TAKES_ARG(STR) \ + (!strcmp (STR, "Tdata") || !strcmp (STR, "Ttext") \ + || !strcmp (STR, "Tbss") || !strcmp (STR, "include") \ + || !strcmp (STR, "imacros") || !strcmp (STR, "aux-info") \ + || !strcmp (STR, "idirafter") || !strcmp (STR, "iprefix") \ + || !strcmp (STR, "iwithprefix") || !strcmp (STR, "iwithprefixbefore") \ + || !strcmp (STR, "isystem")) + +#ifndef WORD_SWITCH_TAKES_ARG +#define WORD_SWITCH_TAKES_ARG(STR) DEFAULT_WORD_SWITCH_TAKES_ARG (STR) +#endif + +/* This is the common prefix we use to make temp file names. + It is chosen once for each run of this program. + It is substituted into a spec by %g. + Thus, all temp file names contain this prefix. + In practice, all temp file names start with this prefix. + + This prefix comes from the envvar TMPDIR if it is defined; + otherwise, from the P_tmpdir macro if that is defined; + otherwise, in /usr/tmp or /tmp. */ + +static char *temp_filename; +static char *temp_filename_f; /* Same with ".f" appended. */ + +/* Length of the prefix. */ + +static int temp_filename_length; + +/* The number of errors that have occurred; the link phase will not be + run if this is non-zero. */ +static int error_count = 0; + +/* Number of commands that exited with a signal. */ + +static int signal_count = 0; + +/* END OF STUFF FROM gcc-2.7.0/gcc.c. */ + +char * +my_strerror(e) + int e; +{ + +#ifdef HAVE_STRERROR + return strerror(e); + +#else + + static char buffer[30]; + if (!e) + return ""; + + if (e > 0 && e < sys_nerr) + return sys_errlist[e]; + + sprintf (buffer, "Unknown error %d", e); + return buffer; +#endif +} + +#ifdef HAVE_VPRINTF +/* Output an error message and exit */ + +static void +fatal VPROTO((char *format, ...)) +{ +#ifndef __STDC__ + char *format; +#endif + va_list ap; + + VA_START (ap, format); + +#ifndef __STDC__ + format = va_arg (ap, char*); +#endif + + fprintf (stderr, "%s: ", programname); + vfprintf (stderr, format, ap); + va_end (ap); + fprintf (stderr, "\n"); +#if 0 + /* XXX Not needed for g77 driver. */ + delete_temp_files (); +#endif + exit (1); +} + +static void +error VPROTO((char *format, ...)) +{ +#ifndef __STDC__ + char *format; +#endif + va_list ap; + + VA_START (ap, format); + +#ifndef __STDC__ + format = va_arg (ap, char*); +#endif + + fprintf (stderr, "%s: ", programname); + vfprintf (stderr, format, ap); + va_end (ap); + + fprintf (stderr, "\n"); +} + +#else /* not HAVE_VPRINTF */ + +static void +error (msg, arg1, arg2) + char *msg, *arg1, *arg2; +{ + fprintf (stderr, "%s: ", programname); + fprintf (stderr, msg, arg1, arg2); + fprintf (stderr, "\n"); +} + +static void +fatal (msg, arg1, arg2) + char *msg, *arg1, *arg2; +{ + error (msg, arg1, arg2); +#if 0 + /* XXX Not needed for g77 driver. */ + delete_temp_files (); +#endif + exit (1); +} + +#endif /* not HAVE_VPRINTF */ + +/* More 'friendly' abort that prints the line and file. + config.h can #define abort fancy_abort if you like that sort of thing. */ + +void +fancy_abort () +{ + fatal ("Internal g77 abort."); +} + +char * +xmalloc (size) + unsigned size; +{ + register char *value = (char *) malloc (size); + if (value == 0) + fatal ("virtual memory exhausted"); + return value; +} + +static char * +concat (s1, s2) + char *s1, *s2; +{ + int len1 = strlen (s1); + int len2 = strlen (s2); + char *result = xmalloc (len1 + len2 + 1); + + strcpy (result, s1); + strcpy (result + len1, s2); + *(result + len1 + len2) = 0; + + return result; +} + +static char * +concat3 (s1, s2, s3) + char *s1, *s2, *s3; +{ + return concat (concat (s1, s2), s3); +} + +static char * +concat4 (s1, s2, s3, s4) + char *s1, *s2, *s3, *s4; +{ + return concat (concat (s1, s2), concat (s3, s4)); +} + +static char * +concat6 (s1, s2, s3, s4, s5, s6) + char *s1, *s2, *s3, *s4, *s5, *s6; +{ + return concat3 (concat (s1, s2), concat (s3, s4), concat (s5, s6)); +} + +static void +pfatal_with_name (name) + char *name; +{ + char *s; + + if (errno < sys_nerr) + s = concat ("%s: ", my_strerror (errno)); + else + s = "cannot open `%s'"; + fatal (s, name); +} + +static void +perror_exec (name) + char *name; +{ + char *s; + + if (errno < sys_nerr) + s = concat ("installation problem, cannot exec `%s': ", + my_strerror (errno)); + else + s = "installation problem, cannot exec `%s'"; + error (s, name); +} + +/* Compute a string to use as the base of all temporary file names. + It is substituted for %g. */ + +static char * +choose_temp_base_try (try, base) + char *try; + char *base; +{ + char *rv; + if (base) + rv = base; + else if (try == (char *)0) + rv = 0; + else if (access (try, R_OK | W_OK) != 0) + rv = 0; + else + rv = try; + return rv; +} + +static void +choose_temp_base () +{ + char *base = 0; + int len; + + base = choose_temp_base_try (getenv ("TMPDIR"), base); + base = choose_temp_base_try (getenv ("TMP"), base); + base = choose_temp_base_try (getenv ("TEMP"), base); + +#ifdef P_tmpdir + base = choose_temp_base_try (P_tmpdir, base); +#endif + + base = choose_temp_base_try (concat4 (dir_separator_str, "usr", + dir_separator_str, "tmp"), + base); + base = choose_temp_base_try (concat (dir_separator_str, "tmp"), base); + + /* If all else fails, use the current directory! */ + if (base == (char *)0) + base = concat (".", dir_separator_str); + + len = strlen (base); + temp_filename = xmalloc (len + strlen (concat (dir_separator_str, + "gfXXXXXX")) + 1); + strcpy (temp_filename, base); + if (len > 0 && temp_filename[len-1] != '/' + && temp_filename[len-1] != DIR_SEPARATOR) + temp_filename[len++] = DIR_SEPARATOR; + strcpy (temp_filename + len, "gfXXXXXX"); + + mktemp (temp_filename); + temp_filename_length = strlen (temp_filename); + if (temp_filename_length == 0) + abort (); + + temp_filename_f = xmalloc (temp_filename_length + 2); + strcpy (temp_filename_f, temp_filename); + temp_filename_f[temp_filename_length] = '.'; + temp_filename_f[temp_filename_length + 1] = 'f'; + temp_filename_f[temp_filename_length + 2] = '\0'; +} + +/* This structure describes one mapping. */ +struct option_map +{ + /* The long option's name. */ + char *name; + /* The equivalent short option. */ + char *equivalent; + /* Argument info. A string of flag chars; NULL equals no options. + a => argument required. + o => argument optional. + j => join argument to equivalent, making one word. + * => require other text after NAME as an argument. */ + char *arg_info; +}; + +/* This is the table of mappings. Mappings are tried sequentially + for each option encountered; the first one that matches, wins. */ + +struct option_map option_map[] = + { + {"--all-warnings", "-Wall", 0}, + {"--ansi", "-ansi", 0}, + {"--assemble", "-S", 0}, + {"--assert", "-A", "a"}, + {"--comments", "-C", 0}, + {"--compile", "-c", 0}, + {"--debug", "-g", "oj"}, + {"--define-macro", "-D", "a"}, + {"--dependencies", "-M", 0}, + {"--driver", "", 0}, /* Wrapper-specific. */ + {"--dump", "-d", "a"}, + {"--dumpbase", "-dumpbase", "a"}, + {"--entry", "-e", 0}, + {"--extra-warnings", "-W", 0}, + {"--for-assembler", "-Wa", "a"}, + {"--for-linker", "-Xlinker", "a"}, + {"--force-link", "-u", "a"}, + {"--imacros", "-imacros", "a"}, + {"--include", "-include", "a"}, + {"--include-barrier", "-I-", 0}, + {"--include-directory", "-I", "a"}, + {"--include-directory-after", "-idirafter", "a"}, + {"--include-prefix", "-iprefix", "a"}, + {"--include-with-prefix", "-iwithprefix", "a"}, + {"--include-with-prefix-before", "-iwithprefixbefore", "a"}, + {"--include-with-prefix-after", "-iwithprefix", "a"}, + {"--language", "-x", "a"}, + {"--library-directory", "-L", "a"}, + {"--machine", "-m", "aj"}, + {"--machine-", "-m", "*j"}, + {"--no-line-commands", "-P", 0}, + {"--no-precompiled-includes", "-noprecomp", 0}, + {"--no-standard-includes", "-nostdinc", 0}, + {"--no-standard-libraries", "-nostdlib", 0}, + {"--no-warnings", "-w", 0}, + {"--optimize", "-O", "oj"}, + {"--output", "-o", "a"}, + {"--pedantic", "-pedantic", 0}, + {"--pedantic-errors", "-pedantic-errors", 0}, + {"--pipe", "-pipe", 0}, + {"--prefix", "-B", "a"}, + {"--preprocess", "-E", 0}, + {"--print-file-name", "-print-file-name=", "aj"}, + {"--print-libgcc-file-name", "-print-libgcc-file-name", 0}, + {"--print-missing-file-dependencies", "-MG", 0}, + {"--print-multi-lib", "-print-multi-lib", 0}, + {"--print-multi-directory", "-print-multi-directory", 0}, + {"--print-prog-name", "-print-prog-name=", "aj"}, + {"--profile", "-p", 0}, + {"--profile-blocks", "-a", 0}, + {"--quiet", "-q", 0}, + {"--save-temps", "-save-temps", 0}, + {"--shared", "-shared", 0}, + {"--silent", "-q", 0}, + {"--static", "-static", 0}, + {"--symbolic", "-symbolic", 0}, + {"--target", "-b", "a"}, + {"--trace-includes", "-H", 0}, + {"--traditional", "-traditional", 0}, + {"--traditional-cpp", "-traditional-cpp", 0}, + {"--trigraphs", "-trigraphs", 0}, + {"--undefine-macro", "-U", "a"}, + {"--use-version", "-V", "a"}, + {"--user-dependencies", "-MM", 0}, + {"--verbose", "-v", 0}, + {"--version", "-dumpversion", 0}, + {"--warn-", "-W", "*j"}, + {"--write-dependencies", "-MD", 0}, + {"--write-user-dependencies", "-MMD", 0}, + {"--", "-f", "*j"} + }; + +/* Compares --options that take one arg. */ + +static int +opteq (xskip, xarg, opt, name) + int *xskip; + char **xarg; + char *opt; + char *name; +{ + int optlen; + int namelen; + int complen; + int i; + int cmp = strcmp (opt, name); + int skip = 1; + char *arg = NULL; + + if (cmp == 0) + { + /* Easy, a straight match. */ + *xskip = skip; + *xarg = arg; + return cmp; + } + + optlen = strlen (opt); + + for (i = 0; i < sizeof (option_map) / sizeof (option_map[0]); ++i) + { + char *arginfo; + int j; + + arginfo = option_map[i].arg_info; + if (arginfo == NULL) + arginfo = ""; + + namelen = strlen (option_map[i].name); + complen = optlen > namelen ? namelen : optlen; + + if (strncmp (opt, option_map[i].name, complen) == 0) + { + if (optlen < namelen) + { + for (j = i + 1; + j < sizeof (option_map) / sizeof (option_map[0]); + ++j) + if ((strlen (option_map[j].name) >= optlen) + && (strncmp (opt, option_map[j].name, optlen) == 0)) + fatal ("Ambiguous abbreviation `%s'", opt); + } + + if (optlen > namelen) + { + if (opt[namelen] == '=') + { + skip = 0; + arg = opt + namelen + 1; + } + else if (index (arginfo, '*') != 0) + ; + else + continue; + } + else if (index (arginfo, '*') != 0) + fatal ("Incomplete `%s' option", option_map[i].name); + + if (strcmp (name, option_map[i].name) != 0) + return 1; /* Not what is being looked for. */ + + *xskip = skip; + *xarg = arg; + return 0; + } + } + + return 1; +} + +/* Assumes text[0] == '-'. Returns number of argv items that belong to + (and follow) this one, an option id for options important to the + caller, and a pointer to the first char of the arg, if embedded (else + returns NULL, meaning no arg or it's the next argv). */ + +static void +lookup_option (xopt, xskip, xarg, text) + Option *xopt; + int *xskip; + char **xarg; + char *text; +{ + Option opt = OPTION_; + int skip; + char *arg = NULL; + + if ((skip = SWITCH_TAKES_ARG (text[1])) > (text[2] != '\0')) + skip -= (text[2] != '\0'); /* Usually one of "DUoeTuImLA". */ + + if (text[1] == 'B') + opt = OPTION_B, skip = (text[2] == '\0'), arg = text + 2; + else if (text[1] == 'b') + opt = OPTION_b, skip = (text[2] == '\0'), arg = text + 2; + else if ((text[1] == 'c') && (text[2] == '\0')) + opt = OPTION_c, skip = 0; + else if ((text[1] == 'E') && (text[2] == '\0')) + opt = OPTION_E, skip = 0; + else if (text[1] == 'i') + opt = OPTION_i, skip = 0; + else if (text[1] == 'l') + opt = OPTION_l; + else if (text[1] == 'L') + opt = OPTION_L, skip = (text[2] == '\0'), arg = text + 2; + else if (text[1] == 'o') + opt = OPTION_o; + else if ((text[1] == 'S') && (text[2] == '\0')) + opt = OPTION_S, skip = 0; + else if (text[1] == 'V') + opt = OPTION_V, skip = (text[2] == '\0'); + else if ((text[1] == 'v') && (text[2] == '\0')) + opt = OPTION_v, skip = 0; + else if ((text[1] == 'W') && (text[2] == 'l') && (text[3] == ',')) + opt = OPTION_for_linker, skip = 0; + else if (text[1] == 'x') + opt = OPTION_x, skip = (text[2] == '\0'), arg = text + 2; + else + { + if ((skip = WORD_SWITCH_TAKES_ARG (text + 1)) != 0) + /* Usually one of "Tdata", "Ttext", "Tbss", "include", + "imacros", "aux-info", "idirafter", "iprefix", + "iwithprefix", "iwithprefixbefore", "isystem". */ + ; + + if (strcmp (text, "--assemble") == 0) + opt = OPTION_S; + else if (strcmp (text, "--compile") == 0) + opt = OPTION_c; + else if (opteq (&skip, &arg, text, "--driver") == 0) + opt = OPTION_driver; + else if (strcmp (text, "--help") == 0) + opt = OPTION_help; + else if ((opteq (&skip, &arg, text, "--imacros") == 0) + || (opteq (&skip, &arg, text, "--include") == 0) + || (opteq (&skip, &arg, text, "--include-directory-after") == 0) + || (opteq (&skip, &arg, text, "--include-prefix") == 0) + || (opteq (&skip, &arg, text, "--include-with-prefix") == 0) + || (opteq (&skip, &arg, text, "--include-with-prefix-before") == 0) + || (opteq (&skip, &arg, text, "--include-with-prefix-after") == 0)) + opt = OPTION_i; + else if (opteq (&skip, &arg, text, "--language") == 0) + opt = OPTION_x; + else if (opteq (&skip, &arg, text, "--library-directory") == 0) + opt = OPTION_L; + else if ((strcmp (text, "-M") == 0) + || (strcmp (text, "--dependencies") == 0)) + opt = OPTION_M; + else if ((strcmp (text, "-MM") == 0) + || (strcmp (text, "--user-dependencies") == 0)) + opt = OPTION_MM; + else if (strcmp (text, "--output") == 0) + opt = OPTION_o; + else if (opteq (&skip, &arg, text, "--prefix") == 0) + opt = OPTION_B; + else if (strcmp (text, "--preprocess") == 0) + opt = OPTION_E; + else if ((opteq (&skip, &arg, text, "--print-file-name") == 0) + || (strcmp (text, "--print-libgcc-file-name") == 0) + || (strcmp (text, "--print-multi-lib") == 0) + || (strcmp (text, "--print-multi-directory") == 0) + || (opteq (&skip, &arg, text, "--print-prog-name") == 0)) + opt = OPTION_P; + else if ((strcmp (text, "-nostdlib") == 0) + || (strcmp (text, "--no-standard-libraries") == 0) + || (strcmp (text, "-nodefaultlibs") == 0)) + opt = OPTION_nostdlib; + else if (strcmp (text, "-fsyntax-only") == 0) + opt = OPTION_syntax_only; + else if (opteq (&skip, &arg, text, "--use-version") == 0) + opt = OPTION_V; + else if (strcmp (text, "--verbose") == 0) + opt = OPTION_v; + else if (strcmp (text, "--version") == 0) + opt = OPTION_version; + else if (strcmp (text, "-Xlinker") == 0) + skip = 1; + else if ((opteq (&skip, &arg, text, "--assert") == 0) + || (opteq (&skip, &arg, text, "--define-macro") == 0) + || (opteq (&skip, &arg, text, "--dump") == 0) + || (opteq (&skip, &arg, text, "--dumpbase") == 0) + || (opteq (&skip, &arg, text, "--for-assembler") == 0) + || (opteq (&skip, &arg, text, "--for-linker") == 0) + || (opteq (&skip, &arg, text, "--force-link") == 0) + || (opteq (&skip, &arg, text, "--machine") == 0) + || (opteq (&skip, &arg, text, "--target") == 0) + || (opteq (&skip, &arg, text, "--undefine-macro") == 0)) + ; + else + skip = 0; + } + + if (xopt != NULL) + *xopt = opt; + if (xskip != NULL) + *xskip = skip; + if (xarg != NULL) + { + if ((arg != NULL) + && (arg[0] == '\0')) + *xarg = NULL; + else + *xarg = arg; + } +} + +static void +append_arg (arg) + char *arg; +{ + static int newargsize; + +#if 0 + fprintf (stderr, "`%s'\n", arg); +#endif + + if ((newargv == xargv) + && (arg == xargv[newargc])) + { + ++newargc; + return; /* Nothing new here. */ + } + + if (newargv == xargv) + { /* Make new arglist. */ + int i; + + newargsize = (xargc << 2) + 20; + newargv = (char **) malloc (newargsize * sizeof (char *)); + + /* Copy what has been done so far. */ + for (i = 0; i < newargc; ++i) + newargv[i] = xargv[i]; + } + + if (newargc == newargsize) + fatal ("overflowed output arg list for `%s'", arg); + newargv[newargc++] = arg; +} + +extern int execv (), execvp (); + +/* If a stage of compilation returns an exit status >= 1, + compilation of that file ceases. */ + +#define MIN_FATAL_STATUS 1 + +/* stdin file number. */ +#define STDIN_FILE_NO 0 + +/* stdout file number. */ +#define STDOUT_FILE_NO 1 + +/* value of `pipe': port index for reading. */ +#define READ_PORT 0 + +/* value of `pipe': port index for writing. */ +#define WRITE_PORT 1 + +/* Pipe waiting from last process, to be used as input for the next one. + Value is STDIN_FILE_NO if no pipe is waiting + (i.e. the next command is the first of a group). */ + +static int last_pipe_input; + +/* Fork one piped subcommand. FUNC is the system call to use + (either execv or execvp). ARGV is the arg vector to use. + NOT_LAST is nonzero if this is not the last subcommand + (i.e. its output should be piped to the next one.) */ + +#ifdef __MSDOS__ + +#include +static int +pexecute (search_flag, program, argv, not_last) + int search_flag; + char *program; + char *argv[]; + int not_last; +{ +#ifdef __GO32__ + int i = (search_flag ? spawnv : spawnvp) (1, program, argv); +#else + char *scmd, *rf; + FILE *argfile; + int i, el = search_flag ? 0 : 4; + + scmd = (char *)malloc (strlen (program) + strlen (temp_filename) + 6 + el); + rf = scmd + strlen(program) + 2 + el; + sprintf (scmd, "%s%s @%s.gp", program, + (search_flag ? "" : ".exe"), temp_filename); + argfile = fopen (rf, "w"); + if (argfile == 0) + pfatal_with_name (rf); + + for (i=1; argv[i]; i++) + { + char *cp; + for (cp = argv[i]; *cp; cp++) + { + if (*cp == '"' || *cp == '\'' || *cp == '\\' || isspace (*cp)) + fputc ('\\', argfile); + fputc (*cp, argfile); + } + fputc ('\n', argfile); + } + fclose (argfile); + + i = system (scmd); + + remove (rf); +#endif + + if (i == -1) + { + perror_exec (program); + return MIN_FATAL_STATUS << 8; + } + return i << 8; +} + +#endif + +#if !defined(__MSDOS__) && !defined(OS2) && !defined(_WIN32) + +static int +pexecute (search_flag, program, argv, not_last) + int search_flag; + char *program; + char *argv[]; + int not_last; +{ + int (*func)() = (search_flag ? execv : execvp); + int pid; + int pdes[2]; + int input_desc = last_pipe_input; + int output_desc = STDOUT_FILE_NO; + int retries, sleep_interval; + + /* If this isn't the last process, make a pipe for its output, + and record it as waiting to be the input to the next process. */ + + if (not_last) + { + if (pipe (pdes) < 0) + pfatal_with_name ("pipe"); + output_desc = pdes[WRITE_PORT]; + last_pipe_input = pdes[READ_PORT]; + } + else + last_pipe_input = STDIN_FILE_NO; + + /* Fork a subprocess; wait and retry if it fails. */ + sleep_interval = 1; + for (retries = 0; retries < 4; retries++) + { + pid = vfork (); + if (pid >= 0) + break; + sleep (sleep_interval); + sleep_interval *= 2; + } + + switch (pid) + { + case -1: +#ifdef vfork + pfatal_with_name ("fork"); +#else + pfatal_with_name ("vfork"); +#endif + /* NOTREACHED */ + return 0; + + case 0: /* child */ + /* Move the input and output pipes into place, if nec. */ + if (input_desc != STDIN_FILE_NO) + { + close (STDIN_FILE_NO); + dup (input_desc); + close (input_desc); + } + if (output_desc != STDOUT_FILE_NO) + { + close (STDOUT_FILE_NO); + dup (output_desc); + close (output_desc); + } + + /* Close the parent's descs that aren't wanted here. */ + if (last_pipe_input != STDIN_FILE_NO) + close (last_pipe_input); + + /* Exec the program. */ + (*func) (program, argv); + perror_exec (program); + exit (-1); + /* NOTREACHED */ + return 0; + + default: + /* In the parent, after forking. + Close the descriptors that we made for this child. */ + if (input_desc != STDIN_FILE_NO) + close (input_desc); + if (output_desc != STDOUT_FILE_NO) + close (output_desc); + + /* Return child's process number. */ + return pid; + } +} + +#endif /* not __MSDOS__ and not OS2 and not _WIN32 */ + +#if defined(OS2) + +static int +pexecute (search_flag, program, argv, not_last) + int search_flag; + char *program; + char *argv[]; + int not_last; +{ + return (search_flag ? spawnv : spawnvp) (1, program, argv); +} +#endif /* OS2 */ + +#if defined(_WIN32) + +static int +pexecute (search_flag, program, argv, not_last) + int search_flag; + char *program; + char *argv[]; + int not_last; +{ + return (search_flag ? __spawnv : __spawnvp) (1, program, argv); +} +#endif /* _WIN32 */ + +static int +doit (char *program, char **argv) +{ + int pid; + int status; + int ret_code = 0; + + pid = pexecute (0, program, argv, 0); + +#ifdef __MSDOS__ + status = pid; +#else +#ifdef _WIN32 + pid = cwait (&status, pid, WAIT_CHILD); +#else + pid = wait (&status); +#endif +#endif + if (pid < 0) + abort (); + + if (status != 0) + { + if (WIFSIGNALED (status)) + { + fatal ("Internal compiler error: program %s got fatal signal %d", + program, WTERMSIG (status)); + signal_count++; + ret_code = -1; + } + else if (WIFEXITED (status) + && WEXITSTATUS (status) >= MIN_FATAL_STATUS) + ret_code = -1; + } + + return ret_code; +} + +int +main (argc, argv) + int argc; + char **argv; +{ + register int i = 0; + register char *p; + int verbose = 0; + Option opt; + int skip; + char *arg; + int n_infiles = 0; + int n_outfiles = 0; + + /* This will be NULL if we encounter a situation where we should not + link in libf2c. */ + char *library = "-lf2c"; + + /* This will become 0 if anything other than -v and kin (like -V) + is seen, meaning the user is trying to accomplish something. + If it remains nonzero, and the user wants version info, add stuff to + the command line to make gcc invoke all the appropriate phases + to get all the version info. */ + int add_version_magic = 1; + + /* The name of the compiler we will want to run---by default, it + will be the definition of `GCC_NAME', e.g., `gcc'. */ + char *gcc = GCC_NAME; + + /* 0 => -xnone in effect on input/output + 1 => -xfoo in effect on input/output + 2 => -xnone in effect on input, -xf77 on output + 3 => -xnone in effect on input, -xf77-cpp-input on output. + 4 => -xnone in effect on input, -xratfor on output. */ + int saw_speclang = 0; + + /* 0 => initial/reset state + 1 => last arg was -l + 2 => last two args were -l -lm. */ + int saw_library = 0; + + /* Initialize for append_arg(). */ + xargc = argc; + newargv = xargv = argv; + newargc = 0; + + append_arg (argv[0]); + + p = argv[0] + strlen (argv[0]); + while (p != argv[0] && p[-1] != '/') + --p; + programname = p; + + if (argc == 1) + fatal ("No input files specified.\n"); + +#ifndef __MSDOS__ + /* We do a little magic to find out where the main gcc executable + is. If they ran us as /usr/local/bin/g77, then we will look + for /usr/local/bin/gcc; similarly, if they just ran us as `g77', + we'll just look for `gcc'. */ + if (p != argv[0]) + { + *--p = '\0'; + gcc = (char *) malloc ((strlen (argv[0]) + 1 + strlen (GCC_NAME) + 1) + * sizeof (char)); + sprintf (gcc, "%s/%s", argv[0], GCC_NAME); + } +#endif + + /* First pass through arglist. + + If -nostdlib or a "turn-off-linking" option is anywhere in the + command line, don't do any library-option processing (except + relating to -x). Also, if -v is specified, but no other options + that do anything special (allowing -V version, etc.), remember + to add special stuff to make gcc command actually invoke all + the different phases of the compilation process so all the version + numbers can be seen. + + Also, here is where all problems with missing arguments to options + are caught. If this loop is exited normally, it means all options + have the appropriate number of arguments as far as the rest of this + program is concerned. */ + + for (i = 1; i < argc; ++i) + { + if ((argv[i][0] == '+') && (argv[i][1] == 'e')) + { + add_version_magic = 0; + continue; + } + else if ((argv[i][0] != '-') || (argv[i][1] == 0)) + { + ++n_infiles; + add_version_magic = 0; + continue; + } + + lookup_option (&opt, &skip, NULL, argv[i]); + + switch (opt) + { + case OPTION_nostdlib: + case OPTION_c: + case OPTION_S: + case OPTION_syntax_only: + case OPTION_E: + case OPTION_M: + case OPTION_MM: + /* These options disable linking entirely or linking of the + standard libraries. */ + library = NULL; + add_version_magic = 0; + break; + + case OPTION_for_linker: + case OPTION_l: + ++n_infiles; + add_version_magic = 0; + break; + + case OPTION_o: + ++n_outfiles; + add_version_magic = 0; + break; + + case OPTION_v: + if (!verbose) + fprintf (stderr, "g77 version %s\n", ffezzz_version_string); + verbose = 1; + break; + + case OPTION_b: + case OPTION_B: + case OPTION_L: + case OPTION_driver: + case OPTION_i: + case OPTION_V: + /* These options are useful in conjunction with -v to get + appropriate version info. */ + break; + + case OPTION_version: + printf ("\ +GNU Fortran %s\n\ +Copyright (C) 1997 Free Software Foundation, Inc.\n\ +For more version information on components of the GNU Fortran\n\ +compilation system, especially useful when reporting bugs,\n\ +type the command `g77 --verbose'.\n\ +\n\ +GNU Fortran comes with NO WARRANTY, to the extent permitted by law.\n\ +You may redistribute copies of GNU Fortran\n\ +under the terms of the GNU General Public License.\n\ +For more information about these matters, see the file named COPYING\n\ +or type the command `info -f g77 Copying'.\n\ +", ffezzz_version_string); + exit (0); + break; + + case OPTION_help: + printf ("\ +Usage: g77 [OPTION]... FORTRAN-SOURCE...\n\ +\n\ +Compile and link Fortran source code to produce an executable program,\n\ +which by default is named `a.out', and can be invoked with the UNIX\n\ +command `./a.out'.\n\ +\n\ +Options:\n\ +--debug include debugging information in executable.\n\ +--driver=COMMAND specify preprocessor/compiler/linker driver\n\ + to use instead of the default `gcc'.\n\ +--help display this help and exit.\n\ +--optimize[=LEVEL] take extra time and memory to make generated\n\ + executable run faster. LEVEL is 0 for no\n\ + optimization, 1 for normal optimization, and\n\ + increases through 3 for more optimization.\n\ +--output=PROGRAM name the executable PROGRAM instead of a.out;\n\ + invoke with the command `./PROGRAM'.\n\ +--version display version information and exit.\n\ +\n\ +Many other options exist to tailor the compilation process, specify\n\ +the dialect of the Fortran source code, specify details of the\n\ +code-generation methodology, and so on.\n\ +\n\ +For more information on g77 and gcc, type the commands `info -f g77'\n\ +and `info -f gcc' to read the Info documentation on these commands.\n\ +\n\ +Report bugs to fortran@gnu.ai.mit.edu.\n"); + exit (0); + break; + + default: + add_version_magic = 0; + break; + } + + /* This is the one place we check for missing arguments in the + program. */ + + if (i + skip < argc) + i += skip; + else + fatal ("argument to `%s' missing\n", argv[i]); + } + + if ((n_outfiles != 0) && (n_infiles == 0)) + fatal ("No input files; unwilling to write output files"); + + /* Second pass through arglist, transforming arguments as appropriate. */ + + for (i = 1; i < argc; ++i) + { + if (argv[i][0] == '\0') + append_arg (argv[i]); /* Interesting. Just append as is. */ + + else if ((argv[i][0] == '-') && (argv[i][1] != 'l')) + { + /* Not a filename or library. */ + + if (saw_library == 1) /* -l. */ + append_arg ("-lm"); + saw_library = 0; + + lookup_option (&opt, &skip, &arg, argv[i]); + + if (argv[i][1] == '\0') + append_arg (argv[i]); /* "-" == Standard input. */ + + else if (opt == OPTION_x) + { + /* Track input language. */ + char *lang; + + if (arg == NULL) + lang = argv[i+1]; + else + lang = arg; + + saw_speclang = (strcmp (lang, "none") != 0); + } + else if (opt == OPTION_driver) + { + if (arg == NULL) + gcc = argv[i+1]; + else + gcc = arg; + i += skip; + continue; /* Don't append args to new list. */ + } + append_arg (argv[i]); + for (; skip != 0; --skip) + append_arg (argv[++i]); + } + else + { /* A filename/library, not an option. */ + int len; + int want_speclang; + + /* Here, always append the arg _after_ other stuff, possibly. */ + + if (saw_speclang == 1) + saw_library = 0; /* -xfoo currently active. */ + /* Put -xf77 and -xnone around list of filenames ending in + .F or .f, but don't include other filenames or libraries + in that list. */ + else if ((argv[i][0] != '-') /* Not a library. */ + && (len = strlen (argv[i])) > 2 + && ((argv[i][len - 1] == 'F') + || (argv[i][len - 1] == 'f') + || (argv[i][len - 1] == 'r')) + && argv[i][len - 2] == '.') + { /* filename.f or filename.F. or filename.r */ + if (saw_library == 1) /* -l. */ + append_arg ("-lm"); + saw_library = 0; + switch (argv[i][len - 1]) + { + case 'f': + want_speclang = 2; + break; + case 'F': + want_speclang = 3; + break; + case 'r': + want_speclang = 4; + break; + default: + break; + } + if (saw_speclang != want_speclang) + { + switch (want_speclang) + { + case 2: + append_arg ("-xf77"); + break; + case 3: + append_arg ("-xf77-cpp-input"); + break; + case 4: + append_arg ("-xratfor"); + break; + default: + break; + } + saw_speclang = want_speclang; + } + } + else + { /* -lfoo or "alien" filename. */ + if (saw_speclang) + append_arg ("-xnone"); + saw_speclang = 0; + + if (strcmp (argv[i], "-lm") == 0 + || strcmp (argv[i], "-lmath") == 0) + { + if (saw_library == 1) + saw_library = 2; /* -l -lm. */ + else if (library) + { + append_arg (library); + saw_library = 2; /* -l -lm. */ + } + } + else if ((library != NULL) + && (strcmp (argv[i], library) == 0)) + saw_library = 1; /* -l. */ + else + { /* "Alien" library or filename. */ + if (saw_library == 1) + append_arg ("-lm"); + saw_library = 0; + } + } + append_arg (argv[i]); + } + } + + /* Add -lf2c -lm as necessary. */ + + if (!add_version_magic && library) + { /* Doing a link and no -nostdlib. */ + if (saw_speclang) + append_arg ("-xnone"); + switch (saw_library) + { + case 0: + append_arg (library); + case 1: + append_arg ("-lm"); + default: + break; + } + } + else if (add_version_magic && verbose) + { + FILE *fsrc; + + choose_temp_base (); + + append_arg ("-fnull-version"); + append_arg ("-o"); + append_arg (temp_filename); + append_arg ("-xf77-cpp-input"); + append_arg (temp_filename_f); + append_arg ("-xnone"); + if (library) + { + append_arg (library); + append_arg ("-lm"); + } + + fsrc = fopen (temp_filename_f, "w"); + if (fsrc == 0) + pfatal_with_name (fsrc); + fputs (" call g77__fvers;call g77__ivers;call g77__uvers;end\n", fsrc); + fclose (fsrc); + } + + append_arg (NULL); + --newargc; /* Don't count null arg at end. */ + + newargv[0] = gcc; /* This is safe even if newargv == xargv. */ + + if (verbose) + { +#if 0 + if (newargv == xargv) + fprintf (stderr, "[Original:]"); +#endif + + for (i = 0; i < newargc; i++) + fprintf (stderr, " %s", newargv[i]); + fprintf (stderr, "\n"); + } + + if (doit (gcc, newargv) < 0) + ++error_count; + else if (add_version_magic && verbose) + { + char *outargv[2]; + + outargv[0] = temp_filename; + outargv[1] = 0; + + if (doit (temp_filename, outargv) < 0) + ++error_count; + + remove (temp_filename); + remove (temp_filename_f); + } + + exit (error_count > 0 ? (signal_count ? 2 : 1) : 0); + /* NOTREACHED */ + return 0; +} + +#endif /* LANGUAGE_F77 == 1 */ diff --git a/gcc/f/g77.texi b/gcc/f/g77.texi new file mode 100644 index 000000000000..134deb56ceb9 --- /dev/null +++ b/gcc/f/g77.texi @@ -0,0 +1,13831 @@ +\input texinfo @c -*-texinfo-*- +@c fix @set inside @example: +@tex +\gdef\set{\begingroup\catcode` =10 \parsearg\setxxx} +\gdef\setyyy#1 #2\endsetyyy{% + \def\temp{#2}% + \ifx\temp\empty \global\expandafter\let\csname SET#1\endcsname = \empty + \else \setzzz{#1}#2\endsetzzz % Remove the trailing space \setxxx inserted. + \fi + \endgroup +} +@end tex + +@c %**start of header +@setfilename g77.info +@c @setfilename useg77.info +@c @setfilename portg77.info +@c To produce the full manual, use the "g77.info" setfilename, and +@c make sure the following do NOT begin with '@c' (and the @clear lines DO) +@set INTERNALS +@set USING +@c To produce a user-only manual, use the "useg77.info" setfilename, and +@c make sure the following does NOT begin with '@c': +@c @clear INTERNALS +@c To produce a porter-only manual, use the "portg77.info" setfilename, +@c and make sure the following does NOT begin with '@c': +@c @clear USING + +@c (For FSF printing, turn on smallbook; that is all that is needed.) + +@c smallbook + +@ifset INTERNALS +@ifset USING +@settitle Using and Porting GNU Fortran +@end ifset +@end ifset +@c seems reasonable to assume at least one of INTERNALS or USING is set... +@ifclear INTERNALS +@settitle Using GNU Fortran +@end ifclear +@ifclear USING +@settitle Porting GNU Fortran +@end ifclear +@c then again, have some fun +@ifclear INTERNALS +@ifclear USING +@settitle Doing Squat with GNU Fortran +@end ifclear +@end ifclear + +@syncodeindex fn cp +@syncodeindex vr cp +@c %**end of header +@setchapternewpage odd + +@ifinfo +This file explains how to use the GNU Fortran system. + +Published by the Free Software Foundation +59 Temple Place - Suite 330 +Boston, MA 02111-1307 USA + +Copyright (C) 1995-1997 Free Software Foundation, Inc. + +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +@ignore +Permission is granted to process this file through Tex and print the +results, provided the printed document carries copying permission +notice identical to this one except for the removal of this paragraph +(this paragraph not being relevant to the printed manual). + +@end ignore +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided also that the +sections entitled ``GNU General Public License,'' ``Funding for Free +Software,'' and ``Protect Your Freedom---Fight `Look And Feel'@w{}'' are +included exactly as in the original, and provided that the entire +resulting derived work is distributed under the terms of a permission +notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions, +except that the sections entitled ``GNU General Public License,'' +``Funding for Free Software,'' and ``Protect Your Freedom---Fight `Look +And Feel'@w{}'', and this permission notice, may be included in +translations approved by the Free Software Foundation instead of in the +original English. +@end ifinfo + +Contributed by James Craig Burley (@email{burley@@gnu.ai.mit.edu}). +Inspired by a first pass at translating @file{g77-0.5.16/f/DOC} that +was contributed to Craig by David Ronis (@email{ronis@@onsager.chem.mcgill.ca}). + +@finalout +@titlepage +@comment The title is printed in a large font. +@center @titlefont{Using GNU Fortran} +@sp 2 +@center James Craig Burley +@sp 3 +@center Last updated 1997-08-11 +@sp 1 +@c The version number appears some more times in this file. + +@center for version 0.5.21 +@page +@vskip 0pt plus 1filll +Copyright @copyright{} 1995-1997 Free Software Foundation, Inc. +@sp 2 +For GNU Fortran Version 0.5.21* +@sp 1 +Published by the Free Software Foundation @* +59 Temple Place - Suite 330@* +Boston, MA 02111-1307, USA@* +@c Last printed ??ber, 19??.@* +@c Printed copies are available for $? each.@* +@c ISBN ??? +@sp 1 +Permission is granted to make and distribute verbatim copies of +this manual provided the copyright notice and this permission notice +are preserved on all copies. + +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided also that the +sections entitled ``GNU General Public License,'' ``Funding for Free +Software,'' and ``Protect Your Freedom---Fight `Look And Feel'@w{}'' are +included exactly as in the original, and provided that the entire +resulting derived work is distributed under the terms of a permission +notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions, +except that the sections entitled ``GNU General Public License,'' +``Funding for Free Software,'' and ``Protect Your Freedom---Fight `Look +And Feel'@w{}'', and this permission notice, may be included in +translations approved by the Free Software Foundation instead of in the +original English. +@end titlepage +@page + +@ifinfo + +@dircategory Fortran Programming +@direntry +* g77: (g77). The GNU Fortran compilation system. +@end direntry +@node Top, Copying,, (DIR) +@top Introduction +@cindex Introduction + +@ifset INTERNALS +@ifset USING +This manual documents how to run, install and port the GNU Fortran +compiler, as well as its new features and incompatibilities, and how to +report bugs. It corresponds to GNU Fortran version 0.5.21. +@end ifset +@end ifset + +@ifclear INTERNALS +This manual documents how to run and install the GNU Fortran compiler, +as well as its new features and incompatibilities, and how to report +bugs. It corresponds to GNU Fortran version 0.5.21. +@end ifclear +@ifclear USING +This manual documents how to port the GNU Fortran compiler, +as well as its new features and incompatibilities, and how to report +bugs. It corresponds to GNU Fortran version 0.5.21. +@end ifclear + +@end ifinfo +@menu +* Copying:: GNU General Public License says + how you can copy and share GNU Fortran. +* Contributors:: People who have contributed to GNU Fortran. +* Funding:: How to help assure continued work for free software. +* Funding GNU Fortran:: How to help assure continued work on GNU Fortran. +* Look and Feel:: Protect your freedom---fight ``look and feel''. +@ifset USING +* Getting Started:: Finding your way around this manual. +* What is GNU Fortran?:: How @code{g77} fits into the universe. +* G77 and GCC:: You can compile Fortran, C, or other programs. +* Invoking G77:: Command options supported by @code{g77}. +* News:: News about recent releases of @code{g77}. +* Changes:: User-visible changes to recent releases of @code{g77}. +* Language:: The GNU Fortran language. +* Compiler:: The GNU Fortran compiler. +* Other Dialects:: Dialects of Fortran supported by @code{g77}. +* Other Compilers:: Fortran compilers other than @code{g77}. +* Other Languages:: Languages other than Fortran. +* Installation:: How to configure, compile and install GNU Fortran. +* Debugging and Interfacing:: How @code{g77} generates code. +* Collected Fortran Wisdom:: How to avoid Trouble. +* Trouble:: If you have trouble with GNU Fortran. +* Open Questions:: Things we'd like to know. +* Bugs:: How, why, and where to report bugs. +* Service:: How to find suppliers of support for GNU Fortran. +@end ifset +@ifset INTERNALS +* Adding Options:: Guidance on teaching @code{g77} about new options. +* Projects:: Projects for @code{g77} internals hackers. +@end ifset + +* M: Diagnostics. Diagnostics produced by @code{g77}. + +* Index:: Index of concepts and symbol names. +@end menu +@c yes, the "M: " @emph{is} intentional -- bad.def references it (CMPAMBIG)! + +@node Copying +@unnumbered GNU GENERAL PUBLIC LICENSE +@center Version 2, June 1991 + +@display +Copyright @copyright{} 1989, 1991 Free Software Foundation, Inc. +59 Temple Place - Suite 330, Boston, MA 02111-1307, USA + +Everyone is permitted to copy and distribute verbatim copies +of this license document, but changing it is not allowed. +@end display + +@unnumberedsec Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software---to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + +@iftex +@unnumberedsec TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION +@end iftex +@ifinfo +@center TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION +@end ifinfo + +@enumerate 0 +@item +This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The ``Program'', below, +refers to any such program or work, and a ``work based on the Program'' +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term ``modification''.) Each licensee is addressed as ``you''. + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + +@item +You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + +@item +You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + +@enumerate a +@item +You must cause the modified files to carry prominent notices +stating that you changed the files and the date of any change. + +@item +You must cause any work that you distribute or publish, that in +whole or in part contains or is derived from the Program or any +part thereof, to be licensed as a whole at no charge to all third +parties under the terms of this License. + +@item +If the modified program normally reads commands interactively +when run, you must cause it, when started running for such +interactive use in the most ordinary way, to print or display an +announcement including an appropriate copyright notice and a +notice that there is no warranty (or else, saying that you provide +a warranty) and that users may redistribute the program under +these conditions, and telling the user how to view a copy of this +License. (Exception: if the Program itself is interactive but +does not normally print such an announcement, your work based on +the Program is not required to print an announcement.) +@end enumerate + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + +@item +You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + +@enumerate a +@item +Accompany it with the complete corresponding machine-readable +source code, which must be distributed under the terms of Sections +1 and 2 above on a medium customarily used for software interchange; or, + +@item +Accompany it with a written offer, valid for at least three +years, to give any third party, for a charge no more than your +cost of physically performing source distribution, a complete +machine-readable copy of the corresponding source code, to be +distributed under the terms of Sections 1 and 2 above on a medium +customarily used for software interchange; or, + +@item +Accompany it with the information you received as to the offer +to distribute corresponding source code. (This alternative is +allowed only for noncommercial distribution and only if you +received the program in object code or executable form with such +an offer, in accord with Subsection b above.) +@end enumerate + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + +@item +You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + +@item +You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + +@item +Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + +@item +If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + +@item +If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + +@item +The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and ``any +later version'', you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + +@item +If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + +@iftex +@heading NO WARRANTY +@end iftex +@ifinfo +@center NO WARRANTY +@end ifinfo + +@item +BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM ``AS IS'' WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + +@item +IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. +@end enumerate + +@iftex +@heading END OF TERMS AND CONDITIONS +@end iftex +@ifinfo +@center END OF TERMS AND CONDITIONS +@end ifinfo + +@page +@unnumberedsec How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the ``copyright'' line and a pointer to where the full notice is found. + +@smallexample +@var{one line to give the program's name and a brief idea of what it does.} +Copyright (C) 19@var{yy} @var{name of author} + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +@end smallexample + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + +@smallexample +Gnomovision version 69, Copyright (C) 19@var{yy} @var{name of author} +Gnomovision comes with ABSOLUTELY NO WARRANTY; for details +type `show w'. +This is free software, and you are welcome to redistribute it +under certain conditions; type `show c' for details. +@end smallexample + +The hypothetical commands @samp{show w} and @samp{show c} should show +the appropriate parts of the General Public License. Of course, the +commands you use may be called something other than @samp{show w} and +@samp{show c}; they could even be mouse-clicks or menu items---whatever +suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a ``copyright disclaimer'' for the program, if +necessary. Here is a sample; alter the names: + +@smallexample +Yoyodyne, Inc., hereby disclaims all copyright interest in the program +`Gnomovision' (which makes passes at compilers) written by James Hacker. + +@var{signature of Ty Coon}, 1 April 1989 +Ty Coon, President of Vice +@end smallexample + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. + +@node Contributors +@unnumbered Contributors to GNU Fortran +@cindex contributors +@cindex credits + +In addition to James Craig Burley, who wrote the front end, +many people have helped create and improve GNU Fortran. + +@itemize @bullet +@item +The packaging and compiler portions of GNU Fortran are based largely +on the GNU CC compiler. +@xref{Contributors,,Contributors to GNU CC,gcc,Using and Porting GNU CC}, +for more information. + +@item +The run-time library used by GNU Fortran is a repackaged version +of the @code{libf2c} library (combined from the @code{libF77} and +@code{libI77} libraries) provided as part of @code{f2c}, available for +free from @code{netlib} sites on the Internet. + +@item +Cygnus Support and The Free Software Foundation contributed +significant money and/or equipment to Craig's efforts. + +@item +The following individuals served as alpha testers prior to @code{g77}'s +public release. This work consisted of testing, researching, sometimes +debugging, and occasionally providing small amounts of code and fixes +for @code{g77}, plus offering plenty of helpful advice to Craig: + +@itemize @w{} +@item +Jonathan Corbet +@item +Dr.@: Mark Fernyhough +@item +Takafumi Hayashi (The University of AIzu)---@email{takafumi@@u-aizu.ac.jp} +@item +Kate Hedstrom +@item +Michel Kern (INRIA and Rice University)---@email{Michel.Kern@@inria.fr} +@item +Dr.@: A. O. V. Le Blanc +@item +Dave Love +@item +Rick Lutowski +@item +Toon Moene +@item +Rick Niles +@item +Derk Reefman +@item +Wayne K. Schroll +@item +Bill Thorson +@item +Pedro A. M. Vazquez +@item +Ian Watson +@end itemize + +@item +Scott Snyder (@email{snyder@@d0sgif.fnal.gov}) +provided the patch to add rudimentary support +for @code{INTEGER*1}, @code{INTEGER*2}, and +@code{LOGICAL*1}. +This inspired Craig to add further support, +even though the resulting support +would still be incomplete, because version 0.6 is still +a ways off. + +@item +David Ronis (@email{ronis@@onsager.chem.mcgill.ca}) inspired +and encouraged Craig to rewrite the documentation in texinfo +format by contributing a first pass at a translation of the +old @file{g77-0.5.16/f/DOC} file. + +@item +Toon Moene (@email{toon@@moene.indiv.nluug.nl}) performed +some analysis of generated code as part of an overall project +to improve @code{g77} code generation to at least be as good +as @code{f2c} used in conjunction with @code{gcc}. +So far, this has resulted in the three, somewhat +experimental, options added by @code{g77} to the @code{gcc} +compiler and its back end. + +@item +John Carr (@email{jfc@@mit.edu}) wrote the alias analysis improvements. + +@item +Thanks to Mary Cortani and the staff at Craftwork Solutions +(@email{support@@craftwork.com}) for all of their support. + +@item +Many other individuals have helped debug, test, and improve @code{g77} +over the past several years, and undoubtedly more people +will be doing so in the future. +If you have done so, and would like +to see your name listed in the above list, please ask! +The default is that people wish to remain anonymous. +@end itemize + +@node Funding +@chapter Funding Free Software + +If you want to have more free software a few years from now, it makes +sense for you to help encourage people to contribute funds for its +development. The most effective approach known is to encourage +commercial redistributors to donate. + +Users of free software systems can boost the pace of development by +encouraging for-a-fee distributors to donate part of their selling price +to free software developers---the Free Software Foundation, and others. + +The way to convince distributors to do this is to demand it and expect +it from them. So when you compare distributors, judge them partly by +how much they give to free software development. Show distributors +they must compete to be the one who gives the most. + +To make this approach work, you must insist on numbers that you can +compare, such as, ``We will donate ten dollars to the Frobnitz project +for each disk sold.'' Don't be satisfied with a vague promise, such as +``A portion of the profits are donated,'' since it doesn't give a basis +for comparison. + +Even a precise fraction ``of the profits from this disk'' is not very +meaningful, since creative accounting and unrelated business decisions +can greatly alter what fraction of the sales price counts as profit. +If the price you pay is $50, ten percent of the profit is probably +less than a dollar; it might be a few cents, or nothing at all. + +Some redistributors do development work themselves. This is useful too; +but to keep everyone honest, you need to inquire how much they do, and +what kind. Some kinds of development make much more long-term +difference than others. For example, maintaining a separate version of +a program contributes very little; maintaining the standard version of a +program for the whole community contributes much. Easy new ports +contribute little, since someone else would surely do them; difficult +ports such as adding a new CPU to the GNU C compiler contribute more; +major new features or packages contribute the most. + +By establishing the idea that supporting further development is ``the +proper thing to do'' when distributing free software for a fee, we can +assure a steady flow of resources into making more free software. + +@display +Copyright (C) 1994 Free Software Foundation, Inc. +Verbatim copying and redistribution of this section is permitted +without royalty; alteration is not permitted. +@end display + +@node Funding GNU Fortran +@chapter Funding GNU Fortran +@cindex funding improvements +@cindex improvements, funding + +Work on GNU Fortran is still being done mostly by its author, +James Craig Burley (@email{burley@@gnu.ai.mit.edu}), who is a volunteer +for, not an employee of, the Free Software Foundation (FSF). +As with other GNU software, funding is important because it can pay for +needed equipment, personnel, and so on. + +@cindex FSF, funding the +@cindex funding the FSF +The FSF provides information on the best way to fund ongoing +development of GNU software (such as GNU Fortran) in documents +such as the ``GNUS Bulletin''. +Email @email{gnu@@prep.ai.mit.edu} for information on funding the FSF. + +To fund specific GNU Fortran work in particular, the FSF might +provide a means for that, but the FSF does not provide direct funding +to the author of GNU Fortran to continue his work. The FSF has +employee salary restrictions that can be incompatible with the +financial needs of some volunteers, who therefore choose to +remain volunteers and thus be able to be free to do contract work +and otherwise make their own schedules for doing GNU work. + +Still, funding the FSF at least indirectly benefits work +on specific projects like GNU Fortran because it ensures the +continuing operation of the FSF offices, their workstations, their +network connections, and so on, which are invaluable to volunteers. +(Similarly, hiring Cygnus Support can help a project like GNU +Fortran---Cygnus has been a long-time donor of equipment usage to the author +of GNU Fortran, and this too has been invaluable---@xref{Contributors}.) + +Currently, the only way to directly fund the author of GNU Fortran +in his work on that project is to hire him for the work you want +him to do, or donate money to him. +Several people have done this +already, with the result that he has not needed to immediately find +contract work on a few occasions. +If more people did this, he +would be able to plan on not doing contract work for many months and +could thus devote that time to work on projects (such as the planned +changes for 0.6) that require longer timeframes to complete. +For the latest information on the status of the author, do +@kbd{finger -l burley@@gate.gnu.ai.mit.edu} on a UNIX system +(or any system with a command like UNIX @code{finger}). + +Another important way to support work on GNU Fortran is to volunteer +to help out. +Work is needed on documentation, testing, porting +to various machines, and in some cases, coding (although major +changes planned for version 0.6 make it difficult to add manpower to this +area). +Email @email{fortran@@gnu.ai.mit.edu} to volunteer for this work. + +@xref{Funding,,Funding Free Software}, for more information. + +@node Look and Feel +@chapter Protect Your Freedom---Fight ``Look And Feel'' +@c the above chapter heading overflows onto the next line. --mew 1/26/93 + +To preserve the ability to write free software, including replacements +for proprietary software, authors must be free to replicate the +user interface to which users of existing software have become +accustomed. + +@xref{Look and Feel,,Protect Your Freedom---Fight ``Look And Feel'', +gcc,Using and Porting GNU CC}, for more information. + +@node Getting Started +@chapter Getting Started +@cindex getting started +@cindex new users +@cindex newbies +@cindex beginners + +If you don't need help getting started reading the portions +of this manual that are most important to you, you should skip +this portion of the manual. + +If you are new to compilers, especially Fortran compilers, or +new to how compilers are structured under UNIX and UNIX-like +systems, you'll want to see @ref{What is GNU Fortran?}. + +If you are new to GNU compilers, or have used only one GNU +compiler in the past and not had to delve into how it lets +you manage various versions and configurations of @code{gcc}, +you should see @ref{G77 and GCC}. + +Everyone except experienced @code{g77} users should +see @ref{Invoking G77}. + +If you're acquainted with previous versions of @code{g77}, +you should see @ref{News}. +Further, if you've actually used previous versions of @code{g77}, +especially if you've written or modified Fortran code to +be compiled by previous versions of @code{g77}, you +should see @ref{Changes}. + +If you intend to write or otherwise compile code that is +not already strictly conforming ANSI FORTRAN 77---and this +is probably everyone---you should see @ref{Language}. + +If you don't already have @code{g77} installed on your +system, you must see @ref{Installation}. + +If you run into trouble getting Fortran code to compile, +link, run, or work properly, you might find answers +if you see @ref{Debugging and Interfacing}, +see @ref{Collected Fortran Wisdom}, +and see @ref{Trouble}. +You might also find that the problems you are encountering +are bugs in @code{g77}---see @ref{Bugs}, for information on +reporting them, after reading the other material. + +If you need further help with @code{g77}, or with +freely redistributable software in general, +see @ref{Service}. + +If you would like to help the @code{g77} project, +see @ref{Funding GNU Fortran}, for information on +helping financially, and see @ref{Projects}, for information +on helping in other ways. + +If you're generally curious about the future of +@code{g77}, see @ref{Projects}. +If you're curious about its past, +see @ref{Contributors}, +and see @ref{Funding GNU Fortran}. + +To see a few of the questions maintainers of @code{g77} have, +and that you might be able to answer, +see @ref{Open Questions}. + +@ifset USING +@node What is GNU Fortran? +@chapter What is GNU Fortran? +@cindex concepts, basic +@cindex basic concepts + +GNU Fortran, or @code{g77}, is designed initially as a free replacement +for, or alternative to, the UNIX @code{f77} command. +(Similarly, @code{gcc} is designed as a replacement +for the UNIX @code{cc} command.) + +@code{g77} also is designed to fit in well with the other +fine GNU compilers and tools. + +Sometimes these design goals conflict---in such cases, resolution +often is made in favor of fitting in well with Project GNU. +These cases are usually identified in the appropriate +sections of this manual. + +@cindex compilers +As compilers, @code{g77}, @code{gcc}, and @code{f77} +share the following characteristics: + +@itemize @bullet +@cindex source code +@cindex file, source +@cindex code, source +@cindex source file +@item +They read a user's program, stored in a file and +containing instructions written in the appropriate +language (Fortran, C, and so on). +This file contains @dfn{source code}. + +@cindex translation of user programs +@cindex machine code +@cindex code, machine +@cindex mistakes +@item +They translate the user's program into instructions +a computer can carry out more quickly than it takes +to translate the instructions in the first place. +These instructions are called @dfn{machine code}---code +designed to be efficiently translated and processed +by a machine such as a computer. +Humans usually aren't as good writing machine code +as they are at writing Fortran or C, because +it is easy to make tiny mistakes writing machine code. +When writing Fortran or C, it is easy +to make big mistakes. + +@cindex debugger +@cindex bugs, finding +@cindex gdb command +@cindex commands, gdb +@item +They provide information in the generated machine code +that can make it easier to find bugs in the program +(using a debugging tool, called a @dfn{debugger}, +such as @code{gdb}). + +@cindex libraries +@cindex linking +@cindex ld command +@cindex commands, ld +@item +They locate and gather machine code already generated +to perform actions requested by statements in +the user's program. +This machine code is organized +into @dfn{libraries} and is located and gathered +during the @dfn{link} phase of the compilation +process. +(Linking often is thought of as a separate +step, because it can be directly invoked via the +@code{ld} command. +However, the @code{g77} and @code{gcc} +commands, as with most compiler commands, automatically +perform the linking step by calling on @code{ld} +directly, unless asked to not do so by the user.) + +@cindex language, incorrect use of +@cindex incorrect use of language +@item +They attempt to diagnose cases where the user's +program contains incorrect usages of the language. +The @dfn{diagnostics} produced by the compiler +indicate the problem and the location in the user's +source file where the problem was first noticed. +The user can use this information to locate and +fix the problem. +@cindex diagnostics, incorrect +@cindex incorrect diagnostics +@cindex error messages, incorrect +@cindex incorrect error messages +(Sometimes an incorrect usage +of the language leads to a situation where the +compiler can no longer make any sense of what +follows---while a human might be able to---and +thus ends up complaining about many ``problems'' +it encounters that, in fact, stem from just one +problem, usually the first one reported.) + +@cindex warnings +@cindex questionable instructions +@item +They attempt to diagnose cases where the user's +program contains a correct usage of the language, +but instructs the computer to do something questionable. +These diagnostics often are in the form of @dfn{warnings}, +instead of the @dfn{errors} that indicate incorrect +usage of the language. +@end itemize + +How these actions are performed is generally under the +control of the user. +Using command-line options, the user can specify +how persnickety the compiler is to be regarding +the program (whether to diagnose questionable usage +of the language), how much time to spend making +the generated machine code run faster, and so on. + +@cindex components of g77 +@cindex g77, components of +@code{g77} consists of several components: + +@cindex gcc command +@cindex commands, gcc +@itemize @bullet +@item +A modified version of the @code{gcc} command, which also might be +installed as the system's @code{cc} command. +(In many cases, @code{cc} refers to the +system's ``native'' C compiler, which +might be a non-GNU compiler, or an older version +of @code{gcc} considered more stable or that is +used to build the operating system kernel.) + +@cindex g77 command +@cindex commands, g77 +@item +The @code{g77} command itself, which also might be installed as the +system's @code{f77} command. + +@cindex libf2c library +@cindex libraries, libf2c +@cindex run-time library +@item +The @code{libf2c} run-time library. +This library contains the machine code needed to support +capabilities of the Fortran language that are not directly +provided by the machine code generated by the @code{g77} +compilation phase. + +@cindex f771 program +@cindex programs, f771 +@cindex assembler +@cindex as command +@cindex commands, as +@cindex assembly code +@cindex code, assembly +@item +The compiler itself, internally named @code{f771}. + +Note that @code{f771} does not generate machine code directly---it +generates @dfn{assembly code} that is a more readable form +of machine code, leaving the conversion to actual machine code +to an @dfn{assembler}, usually named @code{as}. +@end itemize + +@code{gcc} is often thought of as ``the C compiler'' only, +but it does more than that. +Based on command-line options and the names given for files +on the command line, @code{gcc} determines which actions to perform, including +preprocessing, compiling (in a variety of possible languages), assembling, +and linking. + +@cindex driver, gcc command as +@cindex gcc command as driver +@cindex executable file +@cindex files, executable +@cindex cc1 program +@cindex programs, cc1 +@cindex preprocessor +@cindex cpp program +@cindex programs, cpp +For example, the command @samp{gcc foo.c} @dfn{drives} the file +@file{foo.c} through the preprocessor @code{cpp}, then +the C compiler (internally named +@code{cc1}), then the assembler (usually @code{as}), then the linker +(@code{ld}), producing an executable program named @file{a.out} (on +UNIX systems). + +@cindex cc1plus program +@cindex programs, cc1plus +As another example, the command @samp{gcc foo.cc} would do much the same as +@samp{gcc foo.c}, but instead of using the C compiler named @code{cc1}, +@code{gcc} would use the C++ compiler (named @code{cc1plus}). + +@cindex f771 program +@cindex programs, f771 +In a GNU Fortran installation, @code{gcc} recognizes Fortran source +files by name just like it does C and C++ source files. +It knows to use the Fortran compiler named @code{f771}, instead of +@code{cc1} or @code{cc1plus}, to compile Fortran files. + +@cindex gcc not recognizing Fortran source +@cindex unrecognized file format +@cindex file format not recognized +Non-Fortran-related operation of @code{gcc} is generally +unaffected by installing the GNU Fortran version of @code{gcc}. +However, without the installed version of @code{gcc} being the +GNU Fortran version, @code{gcc} will not be able to compile +and link Fortran programs---and since @code{g77} uses @code{gcc} +to do most of the actual work, neither will @code{g77}! + +@cindex g77 command +@cindex commands, g77 +The @code{g77} command is essentially just a front-end for +the @code{gcc} command. +Fortran users will normally use @code{g77} instead of @code{gcc}, +because @code{g77} +knows how to specify the libraries needed to link with Fortran programs +(@code{libf2c} and @code{lm}). +@code{g77} can still compile and link programs and +source files written in other languages, just like @code{gcc}. + +@cindex printing version information +@cindex version information, printing +The command @samp{g77 -v} is a quick +way to display lots of version information for the various programs +used to compile a typical preprocessed Fortran source file---this +produces much more output than @samp{gcc -v} currently does. +(If it produces an error message near the end of the output---diagnostics +from the linker, usually @code{ld}---you might +have an out-of-date @code{libf2c} that improperly handles +complex arithmetic.)@ +In the output of this command, the line beginning @samp{GNU Fortran Front +End} identifies the version number of GNU Fortran; immediately +preceding that line is a line identifying the version of @code{gcc} +with which that version of @code{g77} was built. + +@cindex libf2c library +@cindex libraries, libf2c +The @code{libf2c} library is distributed with GNU Fortran for +the convenience of its users, but is not part of GNU Fortran. +It contains the procedures +needed by Fortran programs while they are running. + +@cindex in-line code +@cindex code, in-line +For example, while code generated by @code{g77} is likely +to do additions, subtractions, and multiplications @dfn{in line}---in +the actual compiled code---it is not likely to do trigonometric +functions this way. + +Instead, operations like trigonometric +functions are compiled by the @code{f771} compiler +(invoked by @code{g77} when compiling Fortran code) into machine +code that, when run, calls on functions in @code{libf2c}, so +@code{libf2c} must be linked with almost every useful program +having any component compiled by GNU Fortran. +(As mentioned above, the @code{g77} command takes +care of all this for you.) + +The @code{f771} program represents most of what is unique to GNU Fortran. +While much of the @code{libf2c} component is really part of @code{f2c}, +a free Fortran-to-C converter distributed by Bellcore (AT&T), +plus @code{libU77}, provided by Dave Love, +and the @code{g77} command is just a small front-end to @code{gcc}, +@code{f771} is a combination of two rather +large chunks of code. + +@cindex GNU Back End (GBE) +@cindex GBE +@cindex gcc back end +@cindex back end, gcc +@cindex code generator +One chunk is the so-called @dfn{GNU Back End}, or GBE, +which knows how to generate fast code for a wide variety of processors. +The same GBE is used by the C, C++, and Fortran compiler programs @code{cc1}, +@code{cc1plus}, and @code{f771}, plus others. +Often the GBE is referred to as the ``gcc back end'' or +even just ``gcc''---in this manual, the term GBE is used +whenever the distinction is important. + +@cindex GNU Fortran Front End (FFE) +@cindex FFE +@cindex g77 front end +@cindex front end, g77 +The other chunk of @code{f771} is the +majority of what is unique about GNU Fortran---the code that knows how +to interpret Fortran programs to determine what they are intending to +do, and then communicate that knowledge to the GBE for actual compilation +of those programs. +This chunk is called the @dfn{Fortran Front End} (FFE). +The @code{cc1} and @code{cc1plus} programs have their own front ends, +for the C and C++ languages, respectively. +These fronts ends are responsible for diagnosing +incorrect usage of their respective languages by the +programs the process, and are responsible for most of +the warnings about questionable constructs as well. +(The GBE handles producing some warnings, like those +concerning possible references to undefined variables.) + +Because so much is shared among the compilers for various languages, +much of the behavior and many of the user-selectable options for these +compilers are similar. +For example, diagnostics (error messages and +warnings) are similar in appearance; command-line +options like @samp{-Wall} have generally similar effects; and the quality +of generated code (in terms of speed and size) is roughly similar +(since that work is done by the shared GBE). + +@node G77 and GCC +@chapter Compile Fortran, C, or Other Programs +@cindex compiling programs +@cindex programs, compiling + +@cindex gcc command +@cindex commands, gcc +A GNU Fortran installation includes a modified version of the @code{gcc} +command. + +In a non-Fortran installation, @code{gcc} recognizes C, C++, +and Objective-C source files. + +In a GNU Fortran installation, @code{gcc} also recognizes Fortran source +files and accepts Fortran-specific command-line options, plus some +command-line options that are designed to cater to Fortran users +but apply to other languages as well. + +@xref{G++ and GCC,,Compile C; C++; or Objective-C,gcc,Using and Porting GNU CC}, +for information on the way different languages are handled +by the GNU CC compiler (@code{gcc}). + +@cindex g77 command +@cindex commands, g77 +Also provided as part of GNU Fortran is the @code{g77} command. +The @code{g77} command is designed to make compiling and linking Fortran +programs somewhat easier than when using the @code{gcc} command for +these tasks. +It does this by analyzing the command line somewhat and changing it +appropriately before submitting it to the @code{gcc} command. + +@cindex -v option +@cindex g77 options, -v +@cindex options, -v +@cindex -@w{}-driver option +@cindex g77 options, -@w{}-driver +@cindex options, -@w{}-driver +Use the @samp{-v} option with @code{g77} +to see what is going on---the first line of output is the invocation +of the @code{gcc} command. +Use @samp{--driver=true} to disable actual invocation +of @code{gcc} (this works because @samp{true} is the name of a +UNIX command that simply returns success status). + +@node Invoking G77 +@chapter GNU Fortran Command Options +@cindex GNU Fortran command options +@cindex command options +@cindex options, GNU Fortran command + +The @code{g77} command supports all the options supported by the +@code{gcc} command. +@xref{Invoking GCC,,GNU CC Command Options,gcc,Using and Porting GNU CC}, +for information +on the non-Fortran-specific aspects of the @code{gcc} command (and, +therefore, the @code{g77} command). + +The @code{g77} command supports one option not supported by +the @code{gcc} command: + +@table @code +@cindex -@w{}-driver option +@cindex g77 options, -@w{}-driver +@cindex options, -@w{}-driver +@item --driver=@var{command} +Specifies that @var{command}, rather than @code{gcc}, is to +be invoked by @code{g77} to do its job. +For example, within the @code{gcc} build directory after +building GNU Fortran (but without having to install it), +@kbd{./g77 --driver=./xgcc foo.f -B./}. +@end table + +@cindex options, negative forms +@cindex negative forms of options +All other options are supported both by @code{g77} and by @code{gcc} as +modified (and reinstalled) by the @code{g77} distribution. +In some cases, options have positive and negative forms; +the negative form of @samp{-ffoo} would be @samp{-fno-foo}. +This manual documents only one of these two forms, whichever +one is not the default. + +@menu +* Option Summary:: Brief list of all @code{g77} options, + without explanations. +* Overall Options:: Controlling the kind of output: + an executable, object files, assembler files, + or preprocessed source. +* Shorthand Options:: Options that are shorthand for other options. +* Fortran Dialect Options:: Controlling the variant of Fortran language + compiled. +* Warning Options:: How picky should the compiler be? +* Debugging Options:: Symbol tables, measurements, and debugging dumps. +* Optimize Options:: How much optimization? +* Preprocessor Options:: Controlling header files and macro definitions. + Also, getting dependency information for Make. +* Directory Options:: Where to find header files and libraries. + Where to find the compiler executable files. +* Code Gen Options:: Specifying conventions for function calls, data layout + and register usage. +* Environment Variables:: Env vars that affect GNU Fortran. +@end menu + +@node Option Summary +@section Option Summary + +Here is a summary of all the options specific to GNU Fortran, grouped +by type. Explanations are in the following sections. + +@table @emph +@item Overall Options +@xref{Overall Options,,Options Controlling the Kind of Output}. +@smallexample +--driver -fversion -fset-g77-defaults -fno-silent +@end smallexample + +@item Shorthand Options +@xref{Shorthand Options}. +@smallexample +-ff66 -fno-f66 -ff77 -fno-f77 -fugly -fno-ugly +@end smallexample + +@item Fortran Language Options +@xref{Fortran Dialect Options,,Options Controlling Fortran Dialect}. +@smallexample +-ffree-form -fno-fixed-form -ff90 +-fvxt -fdollar-ok -fno-backslash +-fno-ugly-args -fno-ugly-assign -fno-ugly-assumed +-fugly-comma -fugly-complex -fugly-init -fugly-logint +-fonetrip -ftypeless-boz +-fintrin-case-initcap -fintrin-case-upper +-fintrin-case-lower -fintrin-case-any +-fmatch-case-initcap -fmatch-case-upper +-fmatch-case-lower -fmatch-case-any +-fsource-case-upper -fsource-case-lower -fsource-case-preserve +-fsymbol-case-initcap -fsymbol-case-upper +-fsymbol-case-lower -fsymbol-case-any +-fcase-strict-upper -fcase-strict-lower +-fcase-initcap -fcase-upper -fcase-lower -fcase-preserve +-ff2c-intrinsics-delete -ff2c-intrinsics-hide +-ff2c-intrinsics-disable -ff2c-intrinsics-enable +-ff90-intrinsics-delete -ff90-intrinsics-hide +-ff90-intrinsics-disable -ff90-intrinsics-enable +-fgnu-intrinsics-delete -fgnu-intrinsics-hide +-fgnu-intrinsics-disable -fgnu-intrinsics-enable +-fmil-intrinsics-delete -fmil-intrinsics-hide +-fmil-intrinsics-disable -fmil-intrinsics-enable +-funix-intrinsics-delete -funix-intrinsics-hide +-funix-intrinsics-disable -funix-intrinsics-enable +-fvxt-intrinsics-delete -fvxt-intrinsics-hide +-fvxt-intrinsics-disable -fvxt-intrinsics-enable +-ffixed-line-length-@var{n} -ffixed-line-length-none +@end smallexample + +@item Warning Options +@xref{Warning Options,,Options to Request or Suppress Warnings}. +@smallexample +-fsyntax-only -pedantic -pedantic-errors -fpedantic +-w -Wno-globals -Wimplicit -Wunused -Wuninitialized +-Wall -Wsurprising +-Werror -W +@end smallexample + +@item Debugging Options +@xref{Debugging Options,,Options for Debugging Your Program or GCC}. +@smallexample +-g +@end smallexample + +@item Optimization Options +@xref{Optimize Options,,Options that Control Optimization}. +@smallexample +-malign-double +-ffloat-store -fforce-mem -fforce-addr -fno-inline +-ffast-math -fstrength-reduce -frerun-cse-after-loop +-fexpensive-optimizations -fdelayed-branch +-fschedule-insns -fschedule-insn2 -fcaller-saves +-funroll-loops -funroll-all-loops +-fno-move-all-movables -fno-reduce-all-givs +-fno-rerun-loop-opt +@end smallexample + +@item Directory Options +@xref{Directory Options,,Options for Directory Search}. +@smallexample +-I@var{dir} -I- +@end smallexample + +@item Code Generation Options +@xref{Code Gen Options,,Options for Code Generation Conventions}. +@smallexample +-fno-automatic -finit-local-zero -fno-f2c +-ff2c-library -fno-underscoring -fno-ident +-fpcc-struct-return -freg-struct-return +-fshort-double -fno-common -fpack-struct +-fzeros -fno-second-underscore +-fdebug-kludge -fno-emulate-complex +-falias-check -fargument-alias +-fargument-noalias -fno-argument-noalias-global +-fno-globals +@end smallexample +@end table + +@menu +* Overall Options:: Controlling the kind of output: + an executable, object files, assembler files, + or preprocessed source. +* Shorthand Options:: Options that are shorthand for other options. +* Fortran Dialect Options:: Controlling the variant of Fortran language + compiled. +* Warning Options:: How picky should the compiler be? +* Debugging Options:: Symbol tables, measurements, and debugging dumps. +* Optimize Options:: How much optimization? +* Preprocessor Options:: Controlling header files and macro definitions. + Also, getting dependency information for Make. +* Directory Options:: Where to find header files and libraries. + Where to find the compiler executable files. +* Code Gen Options:: Specifying conventions for function calls, data layout + and register usage. +@end menu + +@node Overall Options +@section Options Controlling the Kind of Output +@cindex overall options +@cindex options, overall + +Compilation can involve as many as four stages: preprocessing, code +generation (often what is really meant by the term ``compilation''), +assembly, and linking, always in that order. The first three +stages apply to an individual source file, and end by producing an +object file; linking combines all the object files (those newly +compiled, and those specified as input) into an executable file. + +@cindex file name suffix +@cindex suffixes, file name +@cindex file name extension +@cindex extensions, file name +@cindex file type +@cindex types, file +For any given input file, the file name suffix determines what kind of +program is contained in the file---that is, the language in which the +program is written is generally indicated by the suffix. +Suffixes specific to GNU Fortran are listed below. +@xref{Overall Options,,gcc,Using and Porting GNU CC}, for +information on suffixes recognized by GNU CC. + +@table @code +@item @var{file}.f +@item @var{file}.for +Fortran source code that should not be preprocessed. + +Such source code cannot contain any preprocessor directives, such +as @code{#include}, @code{#define}, @code{#if}, and so on. + +@cindex preprocessor +@cindex C preprocessor +@cindex cpp preprocessor +@cindex Fortran preprocessor +@cindex cpp program +@cindex programs, cpp +@cindex .F filename suffix +@cindex .fpp filename suffix +@item @var{file}.F +@item @var{file}.fpp +Fortran source code that must be preprocessed (by the C preprocessor +@code{cpp}, which is part of GNU CC). + +Note that preprocessing is not extended to the contents of +files included by the @code{INCLUDE} directive---the @code{#include} +preprocessor directive must be used instead. + +@cindex Ratfor preprocessor +@cindex programs, ratfor +@cindex .r filename suffix +@item @var{file}.r +Ratfor source code, which must be preprocessed by the @code{ratfor} +command, which is available separately (as it is not yet part of +the GNU Fortran distribution). +@end table + +UNIX users typically use the @file{@var{file}.f} and @file{@var{file}.F} +nomenclature. +Users of other operating systems, especially those that cannot +distinguish upper-case +letters from lower-case letters in their file names, typically use +the @file{@var{file}.for} and @file{@var{file}.fpp} nomenclature. + +@cindex #define +@cindex #include +@cindex #if +Use of the preprocessor @code{cpp} allows use of C-like +constructs such as @code{#define} and @code{#include}, but can +lead to unexpected, even mistaken, results due to Fortran's source file +format. +It is recommended that use of the C preprocessor +be limited to @code{#include} and, in +conjunction with @code{#define}, only @code{#if} and related directives, +thus avoiding in-line macro expansion entirely. +This recommendation applies especially +when using the traditional fixed source form. +With free source form, +fewer unexpected transformations are likely to happen, but use of +constructs such as Hollerith and character constants can nevertheless +present problems, especially when these are continued across multiple +source lines. +These problems result, primarily, from differences between the way +such constants are interpreted by the C preprocessor and by a Fortran +compiler. + +@emph{Note:} The @samp{-traditional} and @samp{-undef} flags are supplied +to @code{cpp} by default, to avoid unpleasant surprises. +@xref{Preprocessor Options,,Options Controlling the Preprocessor, +gcc,Using and Porting GNU CC}. +This means that ANSI C preprocessor features (such as the @samp{#} +operator) aren't available, and only variables in the C reserved +namespace (generally, names with a leading underscore) are liable to +substitution by C predefines. +Thus, if you want to do system-specific +tests, use, for example, @samp{#ifdef __linux__} rather than @samp{#ifdef linux}. +Use the @samp{-v} option to see exactly how the preprocessor is invoked. + +The following options that affect overall processing are recognized +by the @code{g77} and @code{gcc} commands in a GNU Fortran installation: + +@table @code +@item --driver=@var{command} +This works when invoking only the @code{g77} command, not +when invoking the @code{gcc} command. +@xref{Invoking G77,,GNU Fortran Command Options}, for +information on this option. + +@cindex -fversion option +@cindex options, -fversion +@cindex printing version information +@cindex version information, printing +@item -fversion +Ensure that the @code{g77}-specific version of the compiler phase is reported, +if run. +(This is supplied automatically when @samp{-v} or @samp{--verbose} +is specified as a command-line option for @code{g77} or @code{gcc} +and when the resulting commands compile Fortran source files.) + +@cindex -fset-g77-defaults option +@cindex options, -fset-g77-defaults +@item -fset-g77-defaults +Set up whatever @code{gcc} options are to apply to Fortran +compilations, and avoid running internal consistency checks +that might take some time. + +As of version 0.5.20, this is equivalent to @samp{-fmove-all-movables +-freduce-all-givs -frerun-loop-opt -fargument-noalias-global}. + +This option is supplied automatically when compiling Fortran code +via the @code{g77} or @code{gcc} command. +The description of this option is provided so that users seeing +it in the output of, say, @samp{g77 -v} understand why it is +there. + +@cindex modifying g77 +@cindex code, modifying +Also, developers who run @code{f771} directly might want to specify it +by hand to get the same defaults as they would running @code{f771} +via @code{g77} or @code{gcc}. +However, such developers should, after linking a new @code{f771} +executable, invoke it without this option once, +e.g. via @kbd{./f771 -quiet < /dev/null}, +to ensure that they have not introduced any +internal inconsistencies (such as in the table of +intrinsics) before proceeding---@code{g77} will crash +with a diagnostic if it detects an inconsistency. + +@cindex -fno-silent option +@cindex options, -fno-silent +@cindex @code{f2c} compatibility +@cindex compatibility, @code{f2c} +@cindex status, compilation +@cindex compilation status +@cindex reporting compilation status +@cindex printing compilation status +@item -fno-silent +Print (to @code{stderr}) the names of the program units as +they are compiled, in a form similar to that used by popular +UNIX @code{f77} implementations and @code{f2c}. +@end table + +@xref{Overall Options,,Options Controlling the Kind of Output, +gcc,Using and Porting GNU CC}, for information +on more options that control the overall operation of the @code{gcc} command +(and, by extension, the @code{g77} command). + +@node Shorthand Options +@section Shorthand Options +@cindex shorthand options +@cindex options, shorthand +@cindex macro options +@cindex options, macro + +The following options serve as ``shorthand'' +for other options accepted by the compiler: + +@table @code +@cindex -fugly option +@cindex options, -fugly +@item -fugly +@cindex ugly features +@cindex features, ugly +Specify that certain ``ugly'' constructs are to be quietly accepted. +Same as: + +@smallexample +-fugly-args -fugly-assign -fugly-assumed +-fugly-comma -fugly-complex -fugly-init +-fugly-logint +@end smallexample + +These constructs are considered inappropriate to use in new +or well-maintained portable Fortran code, but widely used +in old code. +@xref{Distensions}, for more information. + +@emph{Note:} The @samp{-fugly} option is likely to +be removed in a future version. +Implicitly enabling all the @samp{-fugly-*} options +is unlikely to be feasible, or sensible, in the future, +so users should learn to specify only those +@samp{-fugly-*} options they really need for a +particular source file. + +@cindex -fno-ugly option +@cindex options, -fno-ugly +@item -fno-ugly +@cindex ugly features +@cindex features, ugly +Specify that all ``ugly'' constructs are to be noisily rejected. +Same as: + +@smallexample +-fno-ugly-args -fno-ugly-assign -fno-ugly-assumed +-fno-ugly-comma -fno-ugly-complex -fno-ugly-init +-fno-ugly-logint +@end smallexample + +@xref{Distensions}, for more information. + +@cindex -ff66 option +@cindex options, -ff66 +@item -ff66 +@cindex FORTRAN 66 +@cindex compatibility, FORTRAN 66 +Specify that the program is written in idiomatic FORTRAN 66. +Same as @samp{-fonetrip -fugly-assumed}. + +The @samp{-fno-f66} option is the inverse of @samp{-ff66}. +As such, it is the same as @samp{-fno-onetrip -fno-ugly-assumed}. + +The meaning of this option is likely to be refined as future +versions of @code{g77} provide more compatibility with other +existing and obsolete Fortran implementations. + +@cindex -ff77 option +@cindex options, -ff77 +@item -ff77 +@cindex UNIX f77 +@cindex @code{f2c} compatibility +@cindex compatibility, @code{f2c} +@cindex @code{f77} compatibility +@cindex compatibility, @code{f77} +Specify that the program is written in idiomatic UNIX FORTRAN 77 +and/or the dialect accepted by the @code{f2c} product. +Same as @samp{-fbackslash -fno-typeless-boz}. + +The meaning of this option is likely to be refined as future +versions of @code{g77} provide more compatibility with other +existing and obsolete Fortran implementations. + +@cindex -fno-f77 option +@cindex options, -fno-f77 +@item -fno-f77 +@cindex UNIX f77 +The @samp{-fno-f77} option is @emph{not} the inverse +of @samp{-ff77}. +It specifies that the program is not written in idiomatic UNIX +FORTRAN 77 or @code{f2c}, but in a more widely portable dialect. +@samp{-fno-f77} is the same as @samp{-fno-backslash}. + +The meaning of this option is likely to be refined as future +versions of @code{g77} provide more compatibility with other +existing and obsolete Fortran implementations. +@end table + +@node Fortran Dialect Options +@section Options Controlling Fortran Dialect +@cindex dialect options +@cindex language dialect options +@cindex options, dialect + +The following options control the dialect of Fortran +that the compiler accepts: + +@table @code +@cindex -ffree-form option +@cindex options, -ffree-form +@cindex -fno-fixed-form option +@cindex options, -fno-fixed-form +@cindex source file form +@cindex free form +@cindex fixed form +@cindex Fortran 90 features +@item -ffree-form +@item -fno-fixed-form +Specify that the source file is written in free form +(introduced in Fortran 90) instead of the more-traditional fixed form. + +@cindex -ff90 option +@cindex options, -ff90 +@cindex Fortran 90 features +@item -ff90 +Allow certain Fortran-90 constructs. + +This option controls whether certain +Fortran 90 constructs are recognized. +(Other Fortran 90 constructs +might or might not be recognized depending on other options such as +@samp{-fvxt}, @samp{-ff90-intrinsics-enable}, and the +current level of support for Fortran 90.) + +@xref{Fortran 90}, for more information. + +@cindex -fvxt option +@cindex options, -fvxt +@item -fvxt +@cindex Fortran 90 features +@cindex VXT features +Specify the treatment of certain constructs that have different +meanings depending on whether the code is written in +GNU Fortran (based on FORTRAN 77 and akin to Fortran 90) +or VXT Fortran (more like VAX FORTRAN). + +The default is @samp{-fno-vxt}. +@samp{-fvxt} specifies that the VXT Fortran interpretations +for those constructs are to be chosen. + +@xref{VXT Fortran}, for more information. + +@cindex -fdollar-ok option +@cindex options, -fdollar-ok +@item -fdollar-ok +@cindex dollar sign +@cindex symbol names +@cindex character set +Allow @samp{$} as a valid character in a symbol name. + +@cindex -fno-backslash option +@cindex options, -fno-backslash +@item -fno-backslash +@cindex backslash +@cindex character constants +@cindex Hollerith constants +Specify that @samp{\} is not to be specially interpreted in character +and Hollerith constants a la C and many UNIX Fortran compilers. + +For example, with @samp{-fbackslash} in effect, @samp{A\nB} specifies +three characters, with the second one being newline. +With @samp{-fno-backslash}, it specifies four characters, +@samp{A}, @samp{\}, @samp{n}, and @samp{B}. + +Note that @code{g77} implements a fairly general form of backslash +processing that is incompatible with the narrower forms supported +by some other compilers. +For example, @samp{'A\003B'} is a three-character string in @code{g77}, +whereas other compilers that support backslash might not support +the three-octal-digit form, and thus treat that string as longer +than three characters. + +@xref{Backslash in Constants}, for +information on why @samp{-fbackslash} is the default +instead of @samp{-fno-backslash}. + +@cindex -fno-ugly-args option +@cindex options, -fno-ugly-args +@item -fno-ugly-args +Disallow passing Hollerith and typeless constants as actual +arguments (for example, @samp{CALL FOO(4HABCD)}). + +@xref{Ugly Implicit Argument Conversion}, for more information. + +@cindex -fugly-assign option +@cindex options, -fugly-assign +@item -fugly-assign +Use the same storage for a given variable regardless of +whether it is used to hold an assigned-statement label +(as in @samp{ASSIGN 10 TO I}) or used to hold numeric data +(as in @samp{I = 3}). + +@xref{Ugly Assigned Labels}, for more information. + +@cindex -fugly-assumed option +@cindex options, -fugly-assumed +@item -fugly-assumed +Assume any dummy array with a final dimension specified as @samp{1} +is really an assumed-size array, as if @samp{*} had been specified +for the final dimension instead of @samp{1}. + +For example, @samp{DIMENSION X(1)} is treated as if it +had read @samp{DIMENSION X(*)}. + +@xref{Ugly Assumed-Size Arrays}, for more information. + +@cindex -fugly-comma option +@cindex options, -fugly-comma +@item -fugly-comma +Treat a trailing comma in an argument list as specification +of a trailing null argument, and treat an empty argument +list as specification of a single null argument. + +For example, @samp{CALL FOO(,)} is treated as +@samp{CALL FOO(%VAL(0), %VAL(0))}. +That is, @emph{two} null arguments are specified +by the procedure call when @samp{-fugly-comma} is in force. +And @samp{F = FUNC()} is treated as @samp{F = FUNC(%VAL(0))}. + +The default behavior, @samp{-fno-ugly-comma}, is to ignore +a single trailing comma in an argument list. + +@xref{Ugly Null Arguments}, for more information. + +@cindex -fugly-complex option +@cindex options, -fugly-complex +@item -fugly-complex +Do not complain about @samp{REAL(@var{expr})} or +@samp{AIMAG(@var{expr})} when @var{expr} is a @code{COMPLEX} +type other than @code{COMPLEX(KIND=1)}---usually +this is used to permit @code{COMPLEX(KIND=2)} +(@code{DOUBLE COMPLEX}) operands. + +The @samp{-ff90} option controls the interpretation +of this construct. + +@xref{Ugly Complex Part Extraction}, for more information. + +@cindex -fno-ugly-init option +@cindex options, -fno-ugly-init +@item -fno-ugly-init +Disallow use of Hollerith and typeless constants as initial +values (in @code{PARAMETER} and @code{DATA} statements), and +use of character constants to +initialize numeric types and vice versa. + +For example, @samp{DATA I/'F'/, CHRVAR/65/, J/4HABCD/} is disallowed by +@samp{-fno-ugly-init}. + +@xref{Ugly Conversion of Initializers}, for more information. + +@cindex -fugly-logint option +@cindex options, -fugly-logint +@item -fugly-logint +Treat @code{INTEGER} and @code{LOGICAL} variables and +expressions as potential stand-ins for each other. + +For example, automatic conversion between @code{INTEGER} and +@code{LOGICAL} is enabled, for many contexts, via this option. + +@xref{Ugly Integer Conversions}, for more information. + +@cindex -fonetrip option +@cindex options, -fonetrip +@item -fonetrip +@cindex FORTRAN 66 +@cindex DO loops, one-trip +@cindex one-trip DO loops +@cindex compatibility, FORTRAN 66 +Imperative executable @code{DO} loops are to be executed at +least once each time they are reached. + +ANSI FORTRAN 77 and more recent versions of the Fortran standard +specify that the body of an imperative @code{DO} loop is not executed +if the number of iterations calculated from the parameters of the +loop is less than 1. +(For example, @samp{DO 10 I = 1, 0}.)@ +Such a loop is called a @dfn{zero-trip loop}. + +Prior to ANSI FORTRAN 77, many compilers implemented @code{DO} loops +such that the body of a loop would be executed at least once, even +if the iteration count was zero. +Fortran code written assuming this behavior is said to require +@dfn{one-trip loops}. +For example, some code written to the FORTRAN 66 standard +expects this behavior from its @code{DO} loops, although that +standard did not specify this behavior. + +The @samp{-fonetrip} option specifies that the source file(s) being +compiled require one-trip loops. + +This option affects only those loops specified by the (imperative) @code{DO} +statement and by implied-@code{DO} lists in I/O statements. +Loops specified by implied-@code{DO} lists in @code{DATA} and +specification (non-executable) statements are not affected. + +@cindex -ftypeless-boz option +@cindex options, -ftypeless-boz +@cindex prefix-radix constants +@cindex constants, prefix-radix +@cindex constants, types +@cindex types, constants +@item -ftypeless-boz +Specifies that prefix-radix non-decimal constants, such as +@samp{Z'ABCD'}, are typeless instead of @code{INTEGER(KIND=1)}. + +You can test for yourself whether a particular compiler treats +the prefix form as @code{INTEGER(KIND=1)} or typeless by running the +following program: + +@smallexample +EQUIVALENCE (I, R) +R = Z'ABCD1234' +J = Z'ABCD1234' +IF (J .EQ. I) PRINT *, 'Prefix form is TYPELESS' +IF (J .NE. I) PRINT *, 'Prefix form is INTEGER' +END +@end smallexample + +Reports indicate that many compilers process this form as +@code{INTEGER(KIND=1)}, though a few as typeless, and at least one +based on a command-line option specifying some kind of +compatibility. + +@cindex -fintrin-case-initcap option +@cindex options, -fintrin-case-initcap +@item -fintrin-case-initcap +@cindex -fintrin-case-upper option +@cindex options, -fintrin-case-upper +@item -fintrin-case-upper +@cindex -fintrin-case-lower option +@cindex options, -fintrin-case-lower +@item -fintrin-case-lower +@cindex -fintrin-case-any option +@cindex options, -fintrin-case-any +@item -fintrin-case-any +Specify expected case for intrinsic names. +@samp{-fintrin-case-lower} is the default. + +@cindex -fmatch-case-initcap option +@cindex options, -fmatch-case-initcap +@item -fmatch-case-initcap +@cindex -fmatch-case-upper option +@cindex options, -fmatch-case-upper +@item -fmatch-case-upper +@cindex -fmatch-case-lower option +@cindex options, -fmatch-case-lower +@item -fmatch-case-lower +@cindex -fmatch-case-any option +@cindex options, -fmatch-case-any +@item -fmatch-case-any +Specify expected case for keywords. +@samp{-fmatch-case-lower} is the default. + +@cindex -fsource-case-upper option +@cindex options, -fsource-case-upper +@item -fsource-case-upper +@cindex -fsource-case-lower option +@cindex options, -fsource-case-lower +@item -fsource-case-lower +@cindex -fsource-case-preserve option +@cindex options, -fsource-case-preserve +@item -fsource-case-preserve +Specify whether source text other than character and Hollerith constants +is to be translated to uppercase, to lowercase, or preserved as is. +@samp{-fsource-case-lower} is the default. + +@cindex -fsymbol-case-initcap option +@cindex options, -fsymbol-case-initcap +@item -fsymbol-case-initcap +@cindex -fsymbol-case-upper option +@cindex options, -fsymbol-case-upper +@item -fsymbol-case-upper +@cindex -fsymbol-case-lower option +@cindex options, -fsymbol-case-lower +@item -fsymbol-case-lower +@cindex -fsymbol-case-any option +@cindex options, -fsymbol-case-any +@item -fsymbol-case-any +Specify valid cases for user-defined symbol names. +@samp{-fsymbol-case-any} is the default. + +@cindex -fcase-strict-upper option +@cindex options, -fcase-strict-upper +@item -fcase-strict-upper +Same as @samp{-fintrin-case-upper -fmatch-case-upper -fsource-case-preserve +-fsymbol-case-upper}. +(Requires all pertinent source to be in uppercase.) + +@cindex -fcase-strict-lower option +@cindex options, -fcase-strict-lower +@item -fcase-strict-lower +Same as @samp{-fintrin-case-lower -fmatch-case-lower -fsource-case-preserve +-fsymbol-case-lower}. +(Requires all pertinent source to be in lowercase.) + +@cindex -fcase-initcap option +@cindex options, -fcase-initcap +@item -fcase-initcap +Same as @samp{-fintrin-case-initcap -fmatch-case-initcap -fsource-case-preserve +-fsymbol-case-initcap}. +(Requires all pertinent source to be in initial capitals, +as in @samp{Print *,SqRt(Value)}.) + +@cindex -fcase-upper option +@cindex options, -fcase-upper +@item -fcase-upper +Same as @samp{-fintrin-case-any -fmatch-case-any -fsource-case-upper +-fsymbol-case-any}. +(Maps all pertinent source to uppercase.) + +@cindex -fcase-lower option +@cindex options, -fcase-lower +@item -fcase-lower +Same as @samp{-fintrin-case-any -fmatch-case-any -fsource-case-lower +-fsymbol-case-any}. +(Maps all pertinent source to lowercase.) + +@cindex -fcase-preserve option +@cindex options, -fcase-preserve +@item -fcase-preserve +Same as @samp{-fintrin-case-any -fmatch-case-any -fsource-case-preserve +-fsymbol-case-any}. +(Preserves all case in user-defined symbols, +while allowing any-case matching of intrinsics and keywords. +For example, @samp{call Foo(i,I)} would pass two @emph{different} +variables named @samp{i} and @samp{I} to a procedure named @samp{Foo}.) + +@cindex -ff2c-intrinsics-delete option +@cindex options, -ff2c-intrinsics-delete +@item -ff2c-intrinsics-delete +@cindex -ff2c-intrinsics-hide option +@cindex options, -ff2c-intrinsics-hide +@item -ff2c-intrinsics-hide +@cindex -ff2c-intrinsics-disable option +@cindex options, -ff2c-intrinsics-disable +@item -ff2c-intrinsics-disable +@cindex -ff2c-intrinsics-enable option +@cindex options, -ff2c-intrinsics-enable +@item -ff2c-intrinsics-enable +@cindex f2c intrinsics +@cindex intrinsics, f2c +Specify status of f2c-specific intrinsics. +@samp{-ff2c-intrinsics-enable} is the default. + +@cindex -ff90-intrinsics-delete option +@cindex options, -ff90-intrinsics-delete +@item -ff90-intrinsics-delete +@cindex -ff90-intrinsics-hide option +@cindex options, -ff90-intrinsics-hide +@item -ff90-intrinsics-hide +@cindex -ff90-intrinsics-disable option +@cindex options, -ff90-intrinsics-disable +@item -ff90-intrinsics-disable +@cindex -ff90-intrinsics-enable option +@cindex options, -ff90-intrinsics-enable +@item -ff90-intrinsics-enable +@cindex Fortran 90 intrinsics +@cindex intrinsics, Fortran 90 +Specify status of F90-specific intrinsics. +@samp{-ff90-intrinsics-enable} is the default. + +@cindex -fgnu-intrinsics-delete option +@cindex options, -fgnu-intrinsics-delete +@item -fgnu-intrinsics-delete +@cindex -fgnu-intrinsics-hide option +@cindex options, -fgnu-intrinsics-hide +@item -fgnu-intrinsics-hide +@cindex -fgnu-intrinsics-disable option +@cindex options, -fgnu-intrinsics-disable +@item -fgnu-intrinsics-disable +@cindex -fgnu-intrinsics-enable option +@cindex options, -fgnu-intrinsics-enable +@item -fgnu-intrinsics-enable +@cindex Digital Fortran features +@cindex COMPLEX intrinsics +@cindex intrinsics, COMPLEX +Specify status of Digital's COMPLEX-related intrinsics. +@samp{-fgnu-intrinsics-enable} is the default. + +@cindex -fmil-intrinsics-delete option +@cindex options, -fmil-intrinsics-delete +@item -fmil-intrinsics-delete +@cindex -fmil-intrinsics-hide option +@cindex options, -fmil-intrinsics-hide +@item -fmil-intrinsics-hide +@cindex -fmil-intrinsics-disable option +@cindex options, -fmil-intrinsics-disable +@item -fmil-intrinsics-disable +@cindex -fmil-intrinsics-enable option +@cindex options, -fmil-intrinsics-enable +@item -fmil-intrinsics-enable +@cindex MIL-STD 1753 +@cindex intrinsics, MIL-STD 1753 +Specify status of MIL-STD-1753-specific intrinsics. +@samp{-fmil-intrinsics-enable} is the default. + +@cindex -funix-intrinsics-delete option +@cindex options, -funix-intrinsics-delete +@item -funix-intrinsics-delete +@cindex -funix-intrinsics-hide option +@cindex options, -funix-intrinsics-hide +@item -funix-intrinsics-hide +@cindex -funix-intrinsics-disable option +@cindex options, -funix-intrinsics-disable +@item -funix-intrinsics-disable +@cindex -funix-intrinsics-enable option +@cindex options, -funix-intrinsics-enable +@item -funix-intrinsics-enable +@cindex UNIX intrinsics +@cindex intrinsics, UNIX +Specify status of UNIX intrinsics. +@samp{-funix-intrinsics-enable} is the default. + +@cindex -fvxt-intrinsics-delete option +@cindex options, -fvxt-intrinsics-delete +@item -fvxt-intrinsics-delete +@cindex -fvxt-intrinsics-hide option +@cindex options, -fvxt-intrinsics-hide +@item -fvxt-intrinsics-hide +@cindex -fvxt-intrinsics-disable option +@cindex options, -fvxt-intrinsics-disable +@item -fvxt-intrinsics-disable +@cindex -fvxt-intrinsics-enable option +@cindex options, -fvxt-intrinsics-enable +@item -fvxt-intrinsics-enable +@cindex VXT intrinsics +@cindex intrinsics, VXT +Specify status of VXT intrinsics. +@samp{-fvxt-intrinsics-enable} is the default. + +@cindex -ffixed-line-length-@var{n} option +@cindex options, -ffixed-line-length-@var{n} +@item -ffixed-line-length-@var{n} +@cindex source file format +@cindex line length +@cindex length of source lines +@cindex fixed-form line length +Set column after which characters are ignored in typical fixed-form +lines in the source file, and through which spaces are assumed (as +if padded to that length) after the ends of short fixed-form lines. + +@cindex card image +@cindex extended-source option +Popular values for @var{n} include 72 (the +standard and the default), 80 (card image), and 132 (corresponds +to ``extended-source'' options in some popular compilers). +@var{n} may be @samp{none}, meaning that the entire line is meaningful +and that continued character constants never have implicit spaces appended +to them to fill out the line. +@samp{-ffixed-line-length-0} means the same thing as +@samp{-ffixed-line-length-none}. + +@xref{Source Form}, for more information. +@end table + +@node Warning Options +@section Options to Request or Suppress Warnings +@cindex options to control warnings +@cindex warning messages +@cindex messages, warning +@cindex suppressing warnings + +Warnings are diagnostic messages that report constructions which +are not inherently erroneous but which are risky or suggest there +might have been an error. + +You can request many specific warnings with options beginning @samp{-W}, +for example @samp{-Wimplicit} to request warnings on implicit +declarations. Each of these specific warning options also has a +negative form beginning @samp{-Wno-} to turn off warnings; +for example, @samp{-Wno-implicit}. This manual lists only one of the +two forms, whichever is not the default. + +These options control the amount and kinds of warnings produced by GNU +Fortran: + +@table @code +@cindex syntax checking +@cindex -fsyntax-only option +@cindex options, -fsyntax-only +@item -fsyntax-only +Check the code for syntax errors, but don't do anything beyond that. + +@cindex -pedantic option +@cindex options, -pedantic +@item -pedantic +Issue warnings for uses of extensions to ANSI FORTRAN 77. +@samp{-pedantic} also applies to C-language constructs where they +occur in GNU Fortran source files, such as use of @samp{\e} in a +character constant within a directive like @samp{#include}. + +Valid ANSI FORTRAN 77 programs should compile properly with or without +this option. +However, without this option, certain GNU extensions and traditional +Fortran features are supported as well. +With this option, many of them are rejected. + +Some users try to use @samp{-pedantic} to check programs for strict ANSI +conformance. +They soon find that it does not do quite what they want---it finds some +non-ANSI practices, but not all. +However, improvements to @code{g77} in this area are welcome. + +@cindex -pedantic-errors option +@cindex options, -pedantic-errors +@item -pedantic-errors +Like @samp{-pedantic}, except that errors are produced rather than +warnings. + +@cindex -fpedantic option +@cindex options, -fpedantic +@item -fpedantic +Like @samp{-pedantic}, but applies only to Fortran constructs. + +@cindex -w option +@cindex options, -w +@item -w +Inhibit all warning messages. + +@cindex -Wno-globals option +@cindex options, -Wno-globals +@item -Wno-globals +@cindex global names, warning +@cindex warnings, global names +Inhibit warnings about use of a name as both a global name +(a subroutine, function, or block data program unit, or a +common block) and implicitly as the name of an intrinsic +in a source file. + +Also inhibit warnings about inconsistent invocations and/or +definitions of global procedures (function and subroutines). +Such inconsistencies include different numbers of arguments +and different types of arguments. + +@cindex -Wimplicit option +@cindex options, -Wimplicit +@item -Wimplicit +@cindex implicit declaration, warning +@cindex warnings, implicit declaration +@cindex -u option +@cindex /WARNINGS=DECLARATIONS switch +@cindex IMPLICIT NONE, similar effect +@cindex effecting IMPLICIT NONE +Warn whenever a variable, array, or function is implicitly +declared. +Has an effect similar to using the @code{IMPLICIT NONE} statement +in every program unit. +(Some Fortran compilers provide this feature by an option +named @samp{-u} or @samp{/WARNINGS=DECLARATIONS}.) + +@cindex -Wunused option +@cindex options, -Wunused +@item -Wunused +@cindex unused variables +@cindex variables, unused +Warn whenever a variable is unused aside from its declaration. + +@cindex -Wuninitialized option +@cindex options, -Wuninitialized +@item -Wuninitialized +@cindex uninitialized variables +@cindex variables, uninitialized +Warn whenever an automatic variable is used without first being initialized. + +These warnings are possible only in optimizing compilation, +because they require data-flow information that is computed only +when optimizing. If you don't specify @samp{-O}, you simply won't +get these warnings. + +These warnings occur only for variables that are candidates for +register allocation. Therefore, they do not occur for a variable +@c that is declared @code{VOLATILE}, or +whose address is taken, or whose size +is other than 1, 2, 4 or 8 bytes. Also, they do not occur for +arrays, even when they are in registers. + +Note that there might be no warning about a variable that is used only +to compute a value that itself is never used, because such +computations may be deleted by data-flow analysis before the warnings +are printed. + +These warnings are made optional because GNU Fortran is not smart +enough to see all the reasons why the code might be correct +despite appearing to have an error. Here is one example of how +this can happen: + +@example +SUBROUTINE DISPAT(J) +IF (J.EQ.1) I=1 +IF (J.EQ.2) I=4 +IF (J.EQ.3) I=5 +CALL FOO(I) +END +@end example + +@noindent +If the value of @code{J} is always 1, 2 or 3, then @code{I} is +always initialized, but GNU Fortran doesn't know this. Here is +another common case: + +@example +SUBROUTINE MAYBE(FLAG) +LOGICAL FLAG +IF (FLAG) VALUE = 9.4 +@dots{} +IF (FLAG) PRINT *, VALUE +END +@end example + +@noindent +This has no bug because @code{VALUE} is used only if it is set. + +@cindex -Wall option +@cindex options, -Wall +@item -Wall +@cindex all warnings +@cindex warnings, all +The @samp{-Wunused} and @samp{-Wuninitialized} options combined. +These are all the +options which pertain to usage that we recommend avoiding and that we +believe is easy to avoid. +(As more warnings are added to @code{g77}, some might +be added to the list enabled by @samp{-Wall}.) +@end table + +The remaining @samp{-W@dots{}} options are not implied by @samp{-Wall} +because they warn about constructions that we consider reasonable to +use, on occasion, in clean programs. + +@table @code +@c @item -W +@c Print extra warning messages for these events: +@c +@c @itemize @bullet +@c @item +@c If @samp{-Wall} or @samp{-Wunused} is also specified, warn about unused +@c arguments. +@c +@c @end itemize +@c +@cindex -Wsurprising option +@cindex options, -Wsurprising +@item -Wsurprising +Warn about ``suspicious'' constructs that are interpreted +by the compiler in a way that might well be surprising to +someone reading the code. +These differences can result in subtle, compiler-dependent +(even machine-dependent) behavioral differences. +The constructs warned about include: + +@itemize @bullet +@item +Expressions having two arithmetic operators in a row, such +as @samp{X*-Y}. +Such a construct is nonstandard, and can produce +unexpected results in more complicated situations such +as @samp{X**-Y*Z}. +@code{g77}, along with many other compilers, interprets +this example differently than many programmers, and a few +other compilers. +Specifically, @code{g77} interprets @samp{X**-Y*Z} as +@samp{(X**(-Y))*Z}, while others might think it should +be interpreted as @samp{X**(-(Y*Z))}. + +A revealing example is the constant expression @samp{2**-2*1.}, +which @code{g77} evaluates to .25, while others might evaluate +it to 0., the difference resulting from the way precedence affects +type promotion. + +(The @samp{-fpedantic} option also warns about expressions +having two arithmetic operators in a row.) + +@item +Expressions with a unary minus followed by an operand and then +a binary operator other than plus or minus. +For example, @samp{-2**2} produces a warning, because +the precedence is @samp{-(2**2)}, yielding -4, not +@samp{(-2)**2}, which yields 4, and which might represent +what a programmer expects. + +An example of an expression producing different results +in a surprising way is @samp{-I*S}, where @var{I} holds +the value @samp{-2147483648} and @var{S} holds @samp{0.5}. +On many systems, negating @var{I} results in the same +value, not a positive number, because it is already the +lower bound of what an @code{INTEGER(KIND=1)} variable can hold. +So, the expression evaluates to a positive number, while +the ``expected'' interpretation, @samp{(-I)*S}, would +evaluate to a negative number. + +Even cases such as @samp{-I*J} produce warnings, +even though, in most configurations and situations, +there is no computational difference between the +results of the two interpretations---the purpose +of this warning is to warn about differing interpretations +and encourage a better style of coding, not to identify +only those places where bugs might exist in the user's +code. + +@cindex DO statement +@cindex statements, DO +@item +@code{DO} loops with @code{DO} variables that are not +of integral type---that is, using @code{REAL} +variables as loop control variables. +Although such loops can be written to work in the +``obvious'' way, the way @code{g77} is required by the +Fortran standard to interpret such code is likely to +be quite different from the way many programmers expect. +(This is true of all @code{DO} loops, but the differences +are pronounced for non-integral loop control variables.) + +@xref{Loops}, for more information. +@end itemize + +@cindex -Werror option +@cindex options, -Werror +@item -Werror +Make all warnings into errors. + +@cindex -W option +@cindex options, -W +@item -W +@cindex extra warnings +@cindex warnings, extra +Turns on ``extra warnings'' and, if optimization is specified +via @samp{-O}, the @samp{-Wuninitialized} option. +(This might change in future versions of @code{g77}.) + +``Extra warnings'' are issued for: + +@itemize @bullet +@item +@cindex unused parameters +@cindex parameters, unused +@cindex unused arguments +@cindex arguments, unused +@cindex unused dummies +@cindex dummies, unused +Unused parameters to a procedure (when @samp{-Wunused} also is +specified). + +@item +@cindex overflow +Overflows involving floating-point constants (not available +for certain configurations). +@end itemize +@end table + +@xref{Warning Options,,Options to Request or Suppress Warnings, +gcc,Using and Porting GNU CC}, for information on more options offered +by the GBE shared by @code{g77}, @code{gcc}, and other GNU compilers. + +Some of these have no effect when compiling programs written in Fortran: + +@table @code +@cindex -Wcomment option +@cindex options, -Wcomment +@item -Wcomment +@cindex -Wformat option +@cindex options, -Wformat +@item -Wformat +@cindex -Wparentheses option +@cindex options, -Wparentheses +@item -Wparentheses +@cindex -Wswitch option +@cindex options, -Wswitch +@item -Wswitch +@cindex -Wtraditional option +@cindex options, -Wtraditional +@item -Wtraditional +@cindex -Wshadow option +@cindex options, -Wshadow +@item -Wshadow +@cindex -Wid-clash-@var{len} option +@cindex options, -Wid-clash-@var{len} +@item -Wid-clash-@var{len} +@cindex -Wlarger-than-@var{len} option +@cindex options, -Wlarger-than-@var{len} +@item -Wlarger-than-@var{len} +@cindex -Wconversion option +@cindex options, -Wconversion +@item -Wconversion +@cindex -Waggregate-return option +@cindex options, -Waggregate-return +@item -Waggregate-return +@cindex -Wredundant-decls option +@cindex options, -Wredundant-decls +@item -Wredundant-decls +@cindex unsupported warnings +@cindex warnings, unsupported +These options all could have some relevant meaning for +GNU Fortran programs, but are not yet supported. +@end table + +@node Debugging Options +@section Options for Debugging Your Program or GNU Fortran +@cindex options, debugging +@cindex debugging information options + +GNU Fortran has various special options that are used for debugging +either your program or @code{g77}. + +@table @code +@cindex -g option +@cindex options, -g +@item -g +Produce debugging information in the operating system's native format +(stabs, COFF, XCOFF, or DWARF). GDB can work with this debugging +information. + +@cindex common blocks +@cindex equivalence areas +@cindex missing debug features +Support for this option in Fortran programs is incomplete. +In particular, names of variables and arrays in common blocks +or that are storage-associated via @code{EQUIVALENCE} are +unavailable to the debugger. + +However, version 0.5.19 of @code{g77} does provide this information +in a rudimentary way, as controlled by the +@samp{-fdebug-kludge} option. + +@xref{Code Gen Options,,Options for Code Generation Conventions}, +for more information. +@end table + +@xref{Debugging Options,,Options for Debugging Your Program or GNU CC, +gcc,Using and Porting GNU CC}, for more information on debugging options. + +@node Optimize Options +@section Options That Control Optimization +@cindex optimize options +@cindex options, optimization + +Most Fortran users will want to use no optimization when +developing and testing programs, and use @samp{-O} or @samp{-O2} when +compiling programs for late-cycle testing and for production use. + +The following flags have particular applicability when +compiling Fortran programs: + +@table @code +@cindex -malign-double option +@cindex options, -malign-double +@item -malign-double +(Intel 386 architecture only.) + +Noticeably improves performance of @code{g77} programs making +heavy use of @code{REAL(KIND=2)} (@code{DOUBLE PRECISION}) data +on some systems. +In particular, systems using Pentium, Pentium Pro, 586, and +686 implementations +of the i386 architecture execute programs faster when +@code{REAL(KIND=2)} (@code{DOUBLE PRECISION}) data are +aligned on 64-bit boundaries +in memory. + +This option can, at least, make benchmark results more consistent +across various system configurations, versions of the program, +and data sets. + +@emph{Note:} The warning in the @code{gcc} documentation about +this option does not apply, generally speaking, to Fortran +code compiled by @code{g77}. + +@emph{Also note:} Apparently due to a @code{gcc} backend bug, +@samp{-malign-double} does not align stack-allocated data (such as +local variables neither @code{SAVE}d nor reckoned to take up too +much space to put on the stack). + +@emph{Also also note:} The negative form of @samp{-malign-double} +is @samp{-mno-align-double}, not @samp{-benign-double}. + +@cindex -ffloat-store option +@cindex options, -ffloat-store +@item -ffloat-store +@cindex IEEE conformance +@cindex conformance, IEEE +Might help a Fortran program that depends on exact IEEE conformance +on some machines, but might slow down a program that doesn't. + +@cindex -fforce-mem option +@cindex options, -fforce-mem +@item -fforce-mem +@cindex -fforce-addr option +@cindex options, -fforce-addr +@item -fforce-addr +@cindex loops, speeding up +@cindex speeding up loops +Might improve optimization of loops. + +@cindex -fno-inline option +@cindex options, -fno-inline +@item -fno-inline +@cindex in-line compilation +@cindex compilation, in-line +Don't compile statement functions inline. +Might reduce the size of a program unit---which might be at +expense of some speed (though it should compile faster). +Note that if you are not optimizing, no functions can be expanded inline. + +@cindex -ffast-math option +@cindex options, -ffast-math +@item -ffast-math +@cindex IEEE conformance +@cindex conformance, IEEE +Might allow some programs designed to not be too dependent +on IEEE behavior for floating-point to run faster, or die trying. + +@cindex -fstrength-reduce option +@cindex options, -fstrength-reduce +@item -fstrength-reduce +@cindex loops, speeding up +@cindex speeding up loops +Might make some loops run faster. + +@cindex -frerun-cse-after-loop option +@cindex options, -frerun-cse-after-loop +@item -frerun-cse-after-loop +@cindex -fexpensive-optimizations option +@cindex options, -fexpensive-optimizations +@item -fexpensive-optimizations +@cindex -fdelayed-branch option +@cindex options, -fdelayed-branch +@item -fdelayed-branch +@cindex -fschedule-insns option +@cindex options, -fschedule-insns +@item -fschedule-insns +@cindex -fschedule-insns2 option +@cindex options, -fschedule-insns2 +@item -fschedule-insns2 +@cindex -fcaller-saves option +@cindex options, -fcaller-saves +@item -fcaller-saves +Might improve performance on some code. + +@cindex -funroll-loops option +@cindex options, -funroll-loops +@item -funroll-loops +@cindex loops, unrolling +@cindex unrolling loops +Definitely improves performance on some code. + +@cindex -funroll-all-loops option +@cindex options, -funroll-all-loops +@item -funroll-all-loops +Definitely improves performance on some code. + +@item -fno-move-all-movables +@cindex -fno-move-all-movables option +@cindex options, -fno-move-all-movables +@item -fno-reduce-all-givs +@cindex -fno-reduce-all-givs option +@cindex options, -fno-reduce-all-givs +@item -fno-rerun-loop-opt +@cindex -fno-rerun-loop-opt option +@cindex options, -fno-rerun-loop-opt +Each of these might improve performance on some code. + +Analysis of Fortran code optimization and the resulting +optimizations triggered by the above options were +contributed by Toon Moene (@email{toon@@moene.indiv.nluug.nl}). + +These three options are intended to be removed someday, once +they have helped determine the efficacy of various +approaches to improving the performance of Fortran code. + +Please let us know how use of these options affects +the performance of your production code. +We're particularly interested in code that runs faster +when these options are @emph{disabled}, and in +non-Fortran code that benefits when they are +@emph{enabled} via the above @code{gcc} command-line options. +@end table + +@xref{Optimize Options,,Options That Control Optimization, +gcc,Using and Porting GNU CC}, for more information on options +to optimize the generated machine code. + +@node Preprocessor Options +@section Options Controlling the Preprocessor +@cindex preprocessor options +@cindex options, preprocessor +@cindex cpp program +@cindex programs, cpp + +These options control the C preprocessor, which is run on each C source +file before actual compilation. + +@xref{Preprocessor Options,,Options Controlling the Preprocessor, +gcc,Using and Porting GNU CC}, for information on C preprocessor options. + +@cindex INCLUDE directive +@cindex directive, INCLUDE +Some of these options also affect how @code{g77} processes the +@code{INCLUDE} directive. +Since this directive is processed even when preprocessing +is not requested, it is not described in this section. +@xref{Directory Options,,Options for Directory Search}, for +information on how @code{g77} processes the @code{INCLUDE} directive. + +However, the @code{INCLUDE} directive does not apply +preprocessing to the contents of the included file itself. + +Therefore, any file that contains preprocessor directives +(such as @code{#include}, @code{#define}, and @code{#if}) +must be included via the @code{#include} directive, not +via the @code{INCLUDE} directive. +Therefore, any file containing preprocessor directives, +if included, is necessarily included by a file that itself +contains preprocessor directives. + +@node Directory Options +@section Options for Directory Search +@cindex directory options +@cindex options, directory search +@cindex search path + +These options affect how the @code{cpp} preprocessor searches +for files specified via the @code{#include} directive. +Therefore, when compiling Fortran programs, they are meaningful +when the preproecssor is used. + +@cindex INCLUDE directive +@cindex directive, INCLUDE +Some of these options also affect how @code{g77} searches +for files specified via the @code{INCLUDE} directive, +although files included by that directive are not, +themselves, preprocessed. +These options are: + +@table @code +@cindex -I- option +@cindex options, -I- +@item -I- +@cindex -Idir option +@cindex options, -Idir +@item -I@var{dir} +@cindex directory search paths for inclusion +@cindex inclusion, directory search paths for +@cindex searching for included files +These affect interpretation of the @code{INCLUDE} directive +(as well as of the @code{#include} directive of the @code{cpp} +preprocessor). + +Note that @samp{-I@var{dir}} must be specified @emph{without} any +spaces between @samp{-I} and the directory name---that is, +@samp{-Ifoo/bar} is valid, but @samp{-I foo/bar} +is rejected by the @code{g77} compiler (though the preprocessor supports +the latter form). +@c this is due to toplev.c's inflexible option processing +Also note that the general behavior of @samp{-I} and +@code{INCLUDE} is pretty much the same as of @samp{-I} with +@code{#include} in the @code{cpp} preprocessor, with regard to +looking for @file{header.gcc} files and other such things. + +@xref{Directory Options,,Options for Directory Search, +gcc,Using and Porting GNU CC}, for information on the @samp{-I} option. +@end table + +@node Code Gen Options +@section Options for Code Generation Conventions +@cindex code generation conventions +@cindex options, code generation +@cindex run-time options + +These machine-independent options control the interface conventions +used in code generation. + +Most of them have both positive and negative forms; the negative form +of @samp{-ffoo} would be @samp{-fno-foo}. In the table below, only +one of the forms is listed---the one which is not the default. You +can figure out the other form by either removing @samp{no-} or adding +it. + +@table @code +@cindex -fno-automatic option +@cindex options, -fno-automatic +@item -fno-automatic +@cindex SAVE statement +@cindex statements, SAVE +Treat each program unit as if the @code{SAVE} statement was specified +for every local variable and array referenced in it. +Does not affect common blocks. +(Some Fortran compilers provide this option under +the name @samp{-static}.) + +@cindex -finit-local-zero option +@cindex options, -finit-local-zero +@item -finit-local-zero +@cindex DATA statement +@cindex statements, DATA +@cindex initialization of local variables +@cindex variables, initialization of +@cindex uninitialized variables +@cindex variables, uninitialized +Specify that variables and arrays that are local to a program unit +(not in a common block and not passed as an argument) are to be initialized +to binary zeros. + +Since there is a run-time penalty for initialization of variables +that are not given the @code{SAVE} attribute, it might be a +good idea to also use @samp{-fno-automatic} with @samp{-finit-local-zero}. + +@cindex -fno-f2c option +@cindex options, -fno-f2c +@item -fno-f2c +@cindex @code{f2c} compatibility +@cindex compatibility, @code{f2c} +Do not generate code designed to be compatible with code generated +by @code{f2c}; use the GNU calling conventions instead. + +The @code{f2c} calling conventions require functions that return +type @code{REAL(KIND=1)} to actually return the C type @code{double}, +and functions that return type @code{COMPLEX} to return the +values via an extra argument in the calling sequence that points +to where to store the return value. +Under the GNU calling conventions, such functions simply return +their results as they would in GNU C---@code{REAL(KIND=1)} functions +return the C type @code{float}, and @code{COMPLEX} functions +return the GNU C type @code{complex} (or its @code{struct} +equivalent). + +This does not affect the generation of code that interfaces with the +@code{libf2c} library. + +However, because the @code{libf2c} library uses @code{f2c} +calling conventions, @code{g77} rejects attempts to pass +intrinsics implemented by routines in this library as actual +arguments when @samp{-fno-f2c} is used, to avoid bugs when +they are actually called by code expecting the GNU calling +conventions to work. + +For example, @samp{INTRINSIC ABS;CALL FOO(ABS)} is +rejected when @samp{-fno-f2c} is in force. +(Future versions of the @code{g77} run-time library might +offer routines that provide GNU-callable versions of the +routines that implement the @code{f2c}-callable intrinsics +that may be passed as actual arguments, so that +valid programs need not be rejected when @samp{-fno-f2c} +is used.) + +@strong{Caution:} If @samp{-fno-f2c} is used when compiling any +source file used in a program, it must be used when compiling +@emph{all} Fortran source files used in that program. + +@c seems kinda dumb to tell people about an option they can't use -- jcb +@c then again, we want users building future-compatible libraries with it. +@cindex -ff2c-library option +@cindex options, -ff2c-library +@item -ff2c-library +Specify that use of @code{libf2c} is required. +This is the default for the current version of @code{g77}. + +Currently it is not +valid to specify @samp{-fno-f2c-library}. +This option is provided so users can specify it in shell +scripts that build programs and libraries that require the +@code{libf2c} library, even when being compiled by future +versions of @code{g77} that might otherwise default to +generating code for an incompatible library. + +@cindex -fno-underscoring option +@cindex options, -fno-underscoring +@item -fno-underscoring +@cindex underscores +@cindex symbol names, underscores +@cindex transforming symbol names +@cindex symbol names, transforming +Do not transform names of entities specified in the Fortran +source file by appending underscores to them. + +With @samp{-funderscoring} in effect, @code{g77} appends two underscores +to names with underscores and one underscore to external names with +no underscores. (@code{g77} also appends two underscores to internal +names with underscores to avoid naming collisions with external names. +The @samp{-fno-second-underscore} option disables appending of the +second underscore in all cases.) + +This is done to ensure compatibility with code produced by many +UNIX Fortran compilers, including @code{f2c}, which perform the +same transformations. + +Use of @samp{-fno-underscoring} is not recommended unless you are +experimenting with issues such as integration of (GNU) Fortran into +existing system environments (vis-a-vis existing libraries, tools, and +so on). + +For example, with @samp{-funderscoring}, and assuming other defaults like +@samp{-fcase-lower} and that @samp{j()} and @samp{max_count()} are +external functions while @samp{my_var} and @samp{lvar} are local variables, +a statement like + +@smallexample +I = J() + MAX_COUNT (MY_VAR, LVAR) +@end smallexample + +@noindent +is implemented as something akin to: + +@smallexample +i = j_() + max_count__(&my_var__, &lvar); +@end smallexample + +With @samp{-fno-underscoring}, the same statement is implemented as: + +@smallexample +i = j() + max_count(&my_var, &lvar); +@end smallexample + +Use of @samp{-fno-underscoring} allows direct specification of +user-defined names while debugging and when interfacing @code{g77}-compiled +code with other languages. + +Note that just because the names match does @emph{not} mean that the +interface implemented by @code{g77} for an external name matches the +interface implemented by some other language for that same name. +That is, getting code produced by @code{g77} to link to code produced +by some other compiler using this or any other method can be only a +small part of the overall solution---getting the code generated by +both compilers to agree on issues other than naming can require +significant effort, and, unlike naming disagreements, linkers normally +cannot detect disagreements in these other areas. + +Also, note that with @samp{-fno-underscoring}, the lack of appended +underscores introduces the very real possibility that a user-defined +external name will conflict with a name in a system library, which +could make finding unresolved-reference bugs quite difficult in some +cases---they might occur at program run time, and show up only as +buggy behavior at run time. + +In future versions of @code{g77}, we hope to improve naming and linking +issues so that debugging always involves using the names as they appear +in the source, even if the names as seen by the linker are mangled to +prevent accidental linking between procedures with incompatible +interfaces. + +@cindex -fno-second-underscore option +@cindex options, -fno-second-underscore +@item -fno-second-underscore +@cindex underscores +@cindex symbol names, underscores +@cindex transforming symbol names +@cindex symbol names, transforming +Do not append a second underscore to names of entities specified +in the Fortran source file. + +This option has no effect if @samp{-fno-underscoring} is +in effect. + +Otherwise, with this option, an external name such as @samp{MAX_COUNT} +is implemented as a reference to the link-time external symbol +@samp{max_count_}, instead of @samp{max_count__}. + +@cindex -fno-ident option +@cindex options, -fno-ident +@item -fno-ident +Ignore the @samp{#ident} directive. + +@cindex -fzeros option +@cindex options, -fzeros +@item -fzeros +Treat initial values of zero as if they were any other value. + +As of version 0.5.18, @code{g77} normally treats @code{DATA} and +other statements that are used to specify initial values of zero +for variables and arrays as if no values were actually specified, +in the sense that no diagnostics regarding multiple initializations +are produced. + +This is done to speed up compiling of programs that initialize +large arrays to zeros. + +Use @samp{-fzeros} to revert to the simpler, slower behavior +that can catch multiple initializations by keeping track of +all initializations, zero or otherwise. + +@emph{Caution:} Future versions of @code{g77} might disregard this option +(and its negative form, the default) or interpret it somewhat +differently. +The interpretation changes will affect only non-standard +programs; standard-conforming programs should not be affected. + +@cindex -fdebug-kludge option +@cindex options, -fdebug-kludge +@item -fdebug-kludge +Emit information on @code{COMMON} and @code{EQUIVALENCE} members +that might help users of debuggers work around lack of proper debugging +information on such members. + +As of version 0.5.19, @code{g77} offers this option to emit +information on members of aggregate areas to help users while debugging. +This information consists of establishing the type and contents of each +such member so that, when a debugger is asked to print the contents, +the printed information provides rudimentary debugging information. +This information identifies the name of the aggregate area (either the +@code{COMMON} block name, or the @code{g77}-assigned name for the +@code{EQUIVALENCE} name) and the offset, in bytes, of the member from +the beginning of the area. + +Using @code{gdb}, this information is not coherently displayed in the Fortran +language mode, so temporarily switching to the C language mode to display the +information is suggested. +Use @samp{set language c} and @samp{set language fortran} to accomplish this. + +For example: + +@smallexample + COMMON /X/A,B + EQUIVALENCE (C,D) + CHARACTER XX*50 + EQUIVALENCE (I,XX(20:20)) + END + +GDB is free software and you are welcome to distribute copies of it + under certain conditions; type "show copying" to see the conditions. +There is absolutely no warranty for GDB; type "show warranty" for details. +GDB 4.16 (lm-gnits-dwim), Copyright 1996 Free Software Foundation, Inc... +(gdb) b MAIN__ +Breakpoint 1 at 0t1200000201120112: file cd.f, line 5. +(gdb) r +Starting program: /home/user/a.out + +Breakpoint 1, MAIN__ () at cd.f:5 +Current language: auto; currently fortran +(gdb) set language c +Warning: the current language does not match this frame. +(gdb) p a +$2 = "At (COMMON) `x_' plus 0 bytes" +(gdb) p b +$3 = "At (COMMON) `x_' plus 4 bytes" +(gdb) p c +$4 = "At (EQUIVALENCE) `__g77_equiv_c' plus 0 bytes" +(gdb) p d +$5 = "At (EQUIVALENCE) `__g77_equiv_c' plus 0 bytes" +(gdb) p i +$6 = "At (EQUIVALENCE) `__g77_equiv_xx' plus 20 bytes" +(gdb) p xx +$7 = "At (EQUIVALENCE) `__g77_equiv_xx' plus 1 bytes" +(gdb) set language fortran +(gdb) +@end smallexample + +@noindent +Use @samp{-fdebug-kludge} to generate this information, +which might make some programs noticeably larger. + +@emph{Caution:} Future versions of @code{g77} might disregard this option +(and its negative form). +Current plans call for this to happen when published versions of @code{g77} +and @code{gdb} exist that provide proper access to debugging information on +@code{COMMON} and @code{EQUIVALENCE} members. + +@cindex -fno-emulate-complex option +@cindex options, -fno-emulate-complex +@item -fno-emulate-complex +Implement @code{COMPLEX} arithmetic using the facilities in +the @code{gcc} back end that provide direct support of +@code{complex} arithmetic, instead of emulating the arithmetic. + +@code{gcc} has some known problems in its back-end support +for @code{complex} arithmetic, due primarily to the support not being +completed as of version 2.7.2.2. +Other front ends for the @code{gcc} back end avoid this problem +by emulating @code{complex} arithmetic at a higher level, so the +back end sees arithmetic on the real and imaginary components. +To make @code{g77} more portable to systems where @code{complex} +support in the @code{gcc} back end is particularly troublesome, +@code{g77} now defaults to performing the same kinds of emulations +done by these other front ends. + +Use @samp{-fno-emulate-complex} to try the @code{complex} support +in the @code{gcc} back end, in case it works and produces faster +programs. +So far, all the known bugs seem to involve compile-time crashes, +rather than the generation of incorrect code. + +Use of this option should not affect how Fortran code compiled +by @code{g77} works in terms of its interfaces to other code, +e.g. that compiled by @code{f2c}. + +@emph{Caution:} Future versions of @code{g77} are likely to change +the default for this option to +@samp{-fno-emulate-complex}, and perhaps someday ignore both forms +of this option. + +Also, it is possible that use of the @samp{-fno-emulate-complex} option +could result in incorrect code being silently produced by @code{g77}. +But, this is generally true of compilers anyway, so, as usual, test +the programs you compile before assuming they are working. + +@cindex -falias-check option +@cindex options, -falias-check +@cindex -fargument-alias option +@cindex options, -fargument-alias +@cindex -fargument-noalias option +@cindex options, -fargument-noalias +@cindex -fno-argument-noalias-global option +@cindex options, -fno-argument-noalias-global +@item -falias-check +@item -fargument-alias +@item -fargument-noalias +@item -fno-argument-noalias-global +These options specify to what degree aliasing +(overlap) +is permitted between +arguments (passed as pointers) and @code{COMMON} (external, or +public) storage. + +The default for Fortran code, as mandated by the FORTRAN 77 and +Fortran 90 standards, is @samp{-fargument-noalias-global}. +The default for code written in the C language family is +@samp{-fargument-alias}. + +Note that, on some systems, compiling with @samp{-fforce-addr} in +effect can produce more optimal code when the default aliasing +options are in effect (and when optimization is enabled). + +@xref{Aliasing Assumed To Work}, for detailed information on the implications +of compiling Fortran code that depends on the ability to alias dummy +arguments. + +@cindex -fno-globals option +@cindex options, -fno-globals +@item -fno-globals +@cindex global names, warning +@cindex warnings, global names +Disable diagnostics about inter-procedural +analysis problems, such as disagreements about the +type of a function or a procedure's argument, +that might cause a compiler crash when attempting +to inline a reference to a procedure within a +program unit. +(The diagnostics themselves are still produced, but +as warnings, unless @samp{-Wno-globals} is specified, +in which case no relevant diagnostics are produced.) + +Further, this option disables such inlining, to +avoid compiler crashes resulting from incorrect +code that would otherwise be diagnosed. + +As such, this option might be quite useful when +compiling existing, ``working'' code that happens +to have a few bugs that do not generally show +themselves, but @code{g77} exposes via a +diagnostic. + +Use of this option therefore has the effect of +instructing @code{g77} to behave more like it did +up through version 0.5.19.1, when it paid little or +no attention to disagreements between program units +about a procedure's type and argument information, +and when it performed no inlining of procedures +(except statement functions). + +Without this option, @code{g77} defaults to performing +the potentially inlining procedures as it started doing +in version 0.5.20, but as of version 0.5.21, it also +diagnoses disagreements that might cause such inlining +to crash the compiler. +@end table + +@xref{Code Gen Options,,Options for Code Generation Conventions, +gcc,Using and Porting GNU CC}, for information on more options +offered by the GBE +shared by @code{g77}, @code{gcc}, and other GNU compilers. + +Some of these do @emph{not} work when compiling programs written in Fortran: + +@table @code +@cindex -fpcc-struct-return option +@cindex options, -fpcc-struct-return +@item -fpcc-struct-return +@cindex -freg-struct-return option +@cindex options, -freg-struct-return +@item -freg-struct-return +You should not use these except strictly the same way as you +used them to build the version of @code{libf2c} with which +you will be linking all code compiled by @code{g77} with the +same option. + +@cindex -fshort-double option +@cindex options, -fshort-double +@item -fshort-double +This probably either has no effect on Fortran programs, or +makes them act loopy. + +@cindex -fno-common option +@cindex options, -fno-common +@item -fno-common +Do not use this when compiling Fortran programs, +or there will be Trouble. + +@cindex -fpack-struct option +@cindex options, -fpack-struct +@item -fpack-struct +This probably will break any calls to the @code{libf2c} library, +at the very least, even if it is built with the same option. +@end table + +@node Environment Variables +@section Environment Variables Affecting GNU Fortran +@cindex environment variables + +GNU Fortran currently does not make use of any environment +variables to control its operation above and beyond those +that affect the operation of @code{gcc}. + +@xref{Environment Variables,,Environment Variables Affecting GNU CC, +gcc,Using and Porting GNU CC}, for information on environment +variables. + +@include news.texi + +@node Changes +@chapter User-visible Changes +@cindex versions, recent +@cindex recent versions +@cindex changes, user-visible +@cindex user-visible changes + +This section describes changes to @code{g77} that are visible +to the programmers who actually write and maintain Fortran +code they compile with @code{g77}. +Information on changes to installation procedures, +changes to the documentation, and bug fixes is +not provided here, unless it is likely to affect how +users use @code{g77}. +@xref{News,,News About GNU Fortran}, for information on +such changes to @code{g77}. + +To find out about existing bugs and ongoing plans for GNU +Fortran, retrieve @url{ftp://alpha.gnu.ai.mit.edu/g77.plan} +or, if you cannot do that, email +@email{fortran@@gnu.ai.mit.edu} asking for a recent copy of the +GNU Fortran @file{.plan} file. + +@heading In 0.5.21: +@itemize @bullet +@item +When the @samp{-W} option is specified, @code{gcc}, @code{g77}, +and other GNU compilers that incorporate the @code{gcc} +back end as modified by @code{g77}, issue +a warning about integer division by constant zero. + +@item +New option @samp{-Wno-globals} disables warnings +about ``suspicious'' use of a name both as a global +name and as the implicit name of an intrinsic, and +warnings about disagreements over the number or natures of +arguments passed to global procedures, or the +natures of the procedures themselves. + +The default is to issue such warnings, which are +new as of this version of @code{g77}. + +@item +New option @samp{-fno-globals} disables diagnostics +about potentially fatal disagreements +analysis problems, such as disagreements over the +number or natures of arguments passed to global +procedures, or the natures of those procedures themselves. + +The default is to issue such diagnostics and flag +the compilation as unsuccessful. +With this option, the diagnostics are issued as +warnings, or, if @samp{-Wno-globals} is specified, +are not issued at all. + +This option also disables inlining of global procedures, +to avoid compiler crashes resulting from coding errors +that these diagnostics normally would identify. + +@item +Fix @code{libU77} routines that accept file names +to strip trailing spaces from them, for consistency +with other implementations. + +@item +Fix @code{SIGNAL} intrinsic so it accepts an +optional third @samp{Status} argument. + +@item +Make many changes to @code{libU77} intrinsics to +support existing code more directly. + +Such changes include allowing both subroutine and +function forms of many routines, changing @code{MCLOCK()} +and @code{TIME()} to return @code{INTEGER(KIND=1)} values, +introducing @code{MCLOCK8()} and @code{TIME8()} to +return @code{INTEGER(KIND=2)} values, +and placing functions that are intended to perform +side effects in a new intrinsic group, @code{badu77}. + +@item +Add options @samp{-fbadu77-intrinsics-delete}, +@samp{-fbadu77-intrinsics-hide}, and so on. + +@item +Add @code{INT2} and @code{INT8} intrinsics. + +@item +Add @code{CPU_TIME} intrinsic. + +@item +@code{CTIME} intrinsic now accepts any @code{INTEGER} +argument, not just @code{INTEGER(KIND=2)}. +@end itemize + +@heading In 0.5.20: +@itemize @bullet +@item +The @samp{-fno-typeless-boz} option is now the default. + +This option specifies that non-decimal-radix +constants using the prefixed-radix form (such as @samp{Z'1234'}) +are to be interpreted as @code{INTEGER(KIND=1)} constants. +Specify @samp{-ftypeless-boz} to cause such +constants to be interpreted as typeless. + +(Version 0.5.19 introduced @samp{-fno-typeless-boz} and +its inverse.) + +@xref{Fortran Dialect Options,,Options Controlling Fortran Dialect}, +for information on the @samp{-ftypeless-boz} option. + +@item +Options @samp{-ff90-intrinsics-enable} and +@samp{-fvxt-intrinsics-enable} now are the +defaults. + +Some programs might use names that clash with +intrinsic names defined (and now enabled) by these +options or by the new @code{libU77} intrinsics. +Users of such programs might need to compile them +differently (using, for example, @samp{-ff90-intrinsics-disable}) +or, better yet, insert appropriate @code{EXTERNAL} +statements specifying that these names are not intended +to be names of intrinsics. + +@item +The @samp{ALWAYS_FLUSH} macro is no longer defined when +building @code{libf2c}, which should result in improved +I/O performance, especially over NFS. + +@emph{Note:} If you have code that depends on the behavior +of @code{libf2c} when built with @samp{ALWAYS_FLUSH} defined, +you will have to modify @code{libf2c} accordingly before +building it from this and future versions of @code{g77}. + +@xref{Output Assumed To Flush}, for more information. + +@item +Dave Love's implementation of @code{libU77} has been +added to the version of @code{libf2c} distributed with +and built by @code{g77}. +@code{g77} now knows about the routines in this library +as intrinsics. + +@item +New option @samp{-fvxt} specifies that the +source file is written in VXT Fortran, instead of GNU Fortran. + +@xref{VXT Fortran}, for more information on the constructs +recognized when the @samp{-fvxt} option is specified. + +@item +The @samp{-fvxt-not-f90} option has been deleted, +along with its inverse, @samp{-ff90-not-vxt}. + +If you used one of these deleted options, you should +re-read the pertinent documentation to determine which +options, if any, are appropriate for compiling your +code with this version of @code{g77}. + +@xref{Other Dialects}, for more information. + +@item +The @samp{-fugly} option now issues a warning, as it +likely will be removed in a future version. + +(Enabling all the @samp{-fugly-*} options is unlikely +to be feasible, or sensible, in the future, +so users should learn to specify only those +@samp{-fugly-*} options they really need for a +particular source file.) + +@item +The @samp{-fugly-assumed} option, introduced in +version 0.5.19, has been changed to +better accommodate old and new code. +@xref{Ugly Assumed-Size Arrays}, for more information. + +@item +Related to supporting Alpha (AXP) machines, the @code{LOC()} +intrinsic and @code{%LOC()} construct now return +values of @code{INTEGER(KIND=0)} type, +as defined by the GNU Fortran language. + +This type is wide enough +(holds the same number of bits) +as the character-pointer type on the machine. + +On most systems, this won't make a noticable difference, +whereas on Alphas and other systems with 64-bit pointers, +the @code{INTEGER(KIND=0)} type is equivalent to @code{INTEGER(KIND=2)} +(often referred to as @code{INTEGER*8}) +instead of the more common @code{INTEGER(KIND=1)} +(often referred to as @code{INTEGER*4}). + +@item +Emulate @code{COMPLEX} arithmetic in the @code{g77} front +end, to avoid bugs in @code{complex} support in the +@code{gcc} back end. +New option @samp{-fno-emulate-complex} +causes @code{g77} to revert the 0.5.19 behavior. + +@item +Dummy arguments are no longer assumed to potentially alias +(overlap) +other dummy arguments or @code{COMMON} areas when any of +these are defined (assigned to) by Fortran code. + +This can result in faster and/or smaller programs when +compiling with optimization enabled, though on some +systems this effect is observed only when @samp{-fforce-addr} +also is specified. + +New options @samp{-falias-check}, @samp{-fargument-alias}, +@samp{-fargument-noalias}, +and @samp{-fno-argument-noalias-global} control the +way @code{g77} handles potential aliasing. + +@xref{Aliasing Assumed To Work}, for detailed information on why the +new defaults might result in some programs no longer working the way they +did when compiled by previous versions of @code{g77}. + +@item +New option @samp{-fugly-assign} specifies that the +same memory locations are to be used to hold the +values assigned by both statements @samp{I = 3} and +@samp{ASSIGN 10 TO I}, for example. +(Normally, @code{g77} uses a separate memory location +to hold assigned statement labels.) + +@xref{Ugly Assigned Labels}, for more information. + +@item +@code{FORMAT} and @code{ENTRY} statements now are allowed to +precede @code{IMPLICIT NONE} statements. + +@item +Enable full support of @code{INTEGER(KIND=2)} +(often referred to as @code{INTEGER*8}) +available in +@code{libf2c} and @file{f2c.h} so that @code{f2c} users +may make full use of its features via the @code{g77} +version of @file{f2c.h} and the @code{INTEGER(KIND=2)} +support routines in the @code{g77} version of @code{libf2c}. + +@item +Improve @code{g77} driver and @code{libf2c} so that @samp{g77 -v} +yields version information on the library. + +@item +The @code{SNGL} and @code{FLOAT} intrinsics now are +specific intrinsics, instead of synonyms for the +generic intrinsic @code{REAL}. + +@item +New intrinsics have been added. +These are @code{REALPART}, @code{IMAGPART}, +@code{COMPLEX}, +@code{LONG}, and @code{SHORT}. + +@item +A new group of intrinsics, @samp{gnu}, has been added +to contain the new @code{REALPART}, @code{IMAGPART}, +and @code{COMPLEX} intrinsics. +An old group, @samp{dcp}, has been removed. +@end itemize + +@heading In 0.5.19: + +@itemize @bullet +@item +A temporary kludge option provides bare-bones information on +@code{COMMON} and @code{EQUIVALENCE} members at debug time. +@xref{Code Gen Options,,Options for Code Generation Conventions}, +for information on the @samp{-fdebug-kludge} option. + +@item +New @samp{-fonetrip} option specifies FORTRAN-66-style +one-trip @code{DO} loops. + +@item +New @samp{-fno-silent} option causes names of program units +to be printed as they are compiled, in a fashion similar to +UNIX @code{f77} and @code{f2c}. + +@item +New @samp{-fugly-assumed} option specifies that arrays +dimensioned via @samp{DIMENSION X(1)}, for example, are to be +treated as assumed-size. + +@item +New @samp{-fno-typeless-boz} option specifies that non-decimal-radix +constants using the prefixed-radix form (such as @samp{Z'1234'}) +are to be interpreted as @code{INTEGER(KIND=1)} constants. + +@item +New @samp{-ff66} option is a ``shorthand'' option that specifies +behaviors considered appropriate for FORTRAN 66 programs. + +@item +New @samp{-ff77} option is a ``shorthand'' option that specifies +behaviors considered appropriate for UNIX @code{f77} programs. + +@item +New @samp{-fugly-comma} and @samp{-fugly-logint} options provided +to perform some of what @samp{-fugly} used to do. +@samp{-fugly} and @samp{-fno-ugly} are now ``shorthand'' options, +in that they do nothing more than enable (or disable) other +@samp{-fugly-*} options. + +@item +Change code generation for list-directed I/O so it allows +for new versions of @code{libf2c} that might return non-zero +status codes for some operations previously assumed to always +return zero. + +This change not only affects how @code{IOSTAT=} variables +are set by list-directed I/O, it also affects whether +@code{END=} and @code{ERR=} labels are reached by these +operations. + +@item +Add intrinsic support for new @code{FTELL} and @code{FSEEK} +procedures in @code{libf2c}. + +@item +Add options @samp{--help} and @samp{--version} to the +@code{g77} command, to conform to GNU coding guidelines. +Also add printing of @code{g77} version number when +the @samp{--verbose} (@samp{-v}) option is used. +@end itemize + +@heading In 0.5.18: + +@itemize @bullet +@item +The @code{BYTE} and @code{WORD} statements now are supported, +to a limited extent. + +@item +@code{INTEGER*1}, @code{INTEGER*2}, @code{INTEGER*8}, +and their @code{LOGICAL} +equivalents, now are supported to a limited extent. +Among the missing elements are complete intrinsic and constant +support. + +@item +Support automatic arrays in procedures. +For example, @samp{REAL A(N)}, where @samp{A} is +not a dummy argument, specifies that @samp{A} is +an automatic array. +The size of @samp{A} is calculated from the value +of @samp{N} each time the procedure is called, +that amount of space is allocated, and that space +is freed when the procedure returns to its caller. + +@item +Add @samp{-fno-zeros} option, enabled by default, +to reduce compile-time CPU and memory usage for +code that provides initial zero values for variables +and arrays. + +@item +Introduce three new options that apply to all compilations +by @code{g77}-aware GNU compilers---@samp{-fmove-all-movables}, +@samp{-freduce-all-givs}, and @samp{-frerun-loop-opt}---which +can improve the run-time performance of some programs. + +@item +Replace much of the existing documentation with a single +Info document. + +@item +New option @samp{-fno-second-underscore}. +@end itemize + +@heading In 0.5.17: + +@itemize @bullet +@item +The @code{ERF()} and @code{ERFC()} intrinsics now are generic +intrinsics, mapping to @code{ERF}/@code{DERF} and +@code{ERFC}/@code{DERFC}, respectively. +@emph{Note:} Use @samp{INTRINSIC ERF,ERFC} in any code that +might reference these as generic intrinsics, to +improve the likelihood of diagnostics (instead of subtle run-time +bugs) when using compilers that don't support these as intrinsics. + +@item +New option @samp{-Wsurprising}. + +@item +DO loops with non-@code{INTEGER} variables now diagnosed only when +@samp{-Wsurprising} specified. +Previously, this was diagnosed @emph{unless} @samp{-fpedantic} or +@samp{-fugly} was specified. +@end itemize + +@heading In 0.5.16: + +@itemize @bullet +@item +@code{libf2c} changed to output a leading zero (0) digit for floating-point +values output via list-directed and formatted output (to bring @code{g77} +more into line with many existing Fortran implementations---the +ANSI FORTRAN 77 standard leaves this choice to the implementation). + +@item +@code{libf2c} no longer built with debugging information +intact, making it much smaller. + +@item +Automatic installation of the @code{g77} command now works. + +@item +Diagnostic messages now more informative, a la @code{gcc}, +including messages like @samp{In function `foo':} and @samp{In file +included from...:}. + +@item +New group of intrinsics called @samp{unix}, including @code{ABORT}, +@code{DERF}, @code{DERFC}, @code{ERF}, @code{ERFC}, @code{EXIT}, +@code{FLUSH}, @code{GETARG}, @code{GETENV}, @code{SIGNAL}, and +@code{SYSTEM}. + +@item +@samp{-funix-intrinsics-@{delete,hide,disable,enable@}} +options added. + +@item +@samp{-fno-underscoring} option added. + +@item +@samp{--driver} option added to the @code{g77} command. + +@item +Support for the @code{gcc} options @samp{-fident} and @samp{-fno-ident} +added. + +@item +@samp{g77 -v} returns much more version info, making the submission +of better bug reports easily. + +@item +Many improvements to the @code{g77} command to better fulfill its role as +a front-end to the @code{gcc} driver. +For example, @code{g77} now +recognizes @samp{--verbose} as a verbose way of specifying @samp{-v}. + +@item +Compiling preprocessed (@file{*.F} and @file{*.fpp}) files now +results in better diagnostics and debugging information, as the +source-location info now is passed all the +way through the compilation process instead of being lost. +@end itemize + +@node Language +@chapter The GNU Fortran Language + +@cindex standard, ANSI FORTRAN 77 +@cindex ANSI FORTRAN 77 standard +@cindex reference works +GNU Fortran supports a variety of extensions to, and dialects +of, the Fortran language. +Its primary base is the ANSI FORTRAN 77 standard, currently available on +the network at @url{http://kumo.swcp.com/fortran/F77_std/f77_std.html} +or in @url{ftp://ftp.ast.cam.ac.uk/pub/michael/}. +It offers some extensions that are popular among users +of UNIX @code{f77} and @code{f2c} compilers, some that +are popular among users of other compilers (such as Digital +products), some that are popular among users of the +newer Fortran 90 standard, and some that are introduced +by GNU Fortran. + +@cindex textbooks +(If you need a text on Fortran, +a few freely available electronic references have pointers from +@url{http://www.fortran.com/fortran/Books/}.) + +Part of what defines a particular implementation of a Fortran +system, such as @code{g77}, is the particular characteristics +of how it supports types, constants, and so on. +Much of this is left up to the implementation by the various +Fortran standards and accepted practice in the industry. + +The GNU Fortran @emph{language} is described below. +Much of the material is organized along the same lines +as the ANSI FORTRAN 77 standard itself. + +@xref{Other Dialects}, for information on features @code{g77} supports +that are not part of the GNU Fortran language. + +@emph{Note}: This portion of the documentation definitely needs a lot +of work! + +@menu +Relationship to the ANSI FORTRAN 77 standard: +* Direction of Language Development:: Where GNU Fortran is headed. +* Standard Support:: Degree of support for the standard. + +Extensions to the ANSI FORTRAN 77 standard: +* Conformance:: +* Notation Used:: +* Terms and Concepts:: +* Characters Lines Sequence:: +* Data Types and Constants:: +* Expressions:: +* Specification Statements:: +* Control Statements:: +* Functions and Subroutines:: +* Scope and Classes of Names:: +@end menu + +@node Direction of Language Development +@section Direction of Language Development +@cindex direction of language development +@cindex features, language +@cindex language features + +The purpose of the following description of the GNU Fortran +language is to promote wide portability of GNU Fortran programs. + +GNU Fortran is an evolving language, due to the +fact that @code{g77} itself is in beta test. +Some current features of the language might later +be redefined as dialects of Fortran supported by @code{g77} +when better ways to express these features are added to @code{g77}, +for example. +Such features would still be supported by +@code{g77}, but would be available only when +one or more command-line options were used. + +The GNU Fortran @emph{language} is distinct from the +GNU Fortran @emph{compilation system} (@code{g77}). + +For example, @code{g77} supports various dialects of +Fortran---in a sense, these are languages other than +GNU Fortran---though its primary +purpose is to support the GNU Fortran language, which also is +described in its documentation and by its implementation. + +On the other hand, non-GNU compilers might offer +support for the GNU Fortran language, and are encouraged +to do so. + +Currently, the GNU Fortran language is a fairly fuzzy object. +It represents something of a cross between what @code{g77} accepts +when compiling using the prevailing defaults and what this +document describes as being part of the language. + +Future versions of @code{g77} are expected to clarify the +definition of the language in the documentation. +Often, this will mean adding new features to the language, in the form +of both new documentation and new support in @code{g77}. +However, it might occasionally mean removing a feature +from the language itself to ``dialect'' status. +In such a case, the documentation would be adjusted +to reflect the change, and @code{g77} itself would likely be changed +to require one or more command-line options to continue supporting +the feature. + +The development of the GNU Fortran language is intended to strike +a balance between: + +@itemize @bullet +@item +Serving as a mostly-upwards-compatible language from the +de facto UNIX Fortran dialect as supported by @code{f77}. + +@item +Offering new, well-designed language features. +Attributes of such features include +not making existing code any harder to read +(for those who might be unaware that the new +features are not in use) and +not making state-of-the-art +compilers take longer to issue diagnostics, +among others. + +@item +Supporting existing, well-written code without gratuitously +rejecting non-standard constructs, regardless of the origin +of the code (its dialect). + +@item +Offering default behavior and command-line options to reduce +and, where reasonable, eliminate the need for programmers to make +any modifications to code that already works in existing +production environments. + +@item +Diagnosing constructs that have different meanings in different +systems, languages, and dialects, while offering clear, +less ambiguous ways to express each of the different meanings +so programmers can change their code appropriately. +@end itemize + +One of the biggest practical challenges for the developers of the +GNU Fortran language is meeting the sometimes contradictory demands +of the above items. + +For example, a feature might be widely used in one popular environment, +but the exact same code that utilizes that feature might not work +as expected---perhaps it might mean something entirely different---in +another popular environment. + +Traditionally, Fortran compilers---even portable ones---have solved this +problem by simply offering the appropriate feature to users of +the respective systems. +This approach treats users of various Fortran systems and dialects +as remote ``islands'', or camps, of programmers, and assume that these +camps rarely come into contact with each other (or, +especially, with each other's code). + +Project GNU takes a radically different approach to software and language +design, in that it assumes that users of GNU software do not necessarily +care what kind of underlying system they are using, regardless +of whether they are using software (at the user-interface +level) or writing it (for example, writing Fortran or C code). + +As such, GNU users rarely need consider just what kind of underlying +hardware (or, in many cases, operating system) they are using at any +particular time. +They can use and write software designed for a general-purpose, +widely portable, heteregenous environment---the GNU environment. + +In line with this philosophy, GNU Fortran must evolve into a product +that is widely ported and portable not only in the sense that it can +be successfully built, installed, and run by users, but in the larger +sense that its users can use it in the same way, and expect largely the +same behaviors from it, regardless of the kind of system they are using +at any particular time. + +This approach constrains the solutions @code{g77} can use to resolve +conflicts between various camps of Fortran users. +If these two camps disagree about what a particular construct should +mean, @code{g77} cannot simply be changed to treat that particular construct as +having one meaning without comment (such as a warning), lest the users +expecting it to have the other meaning are unpleasantly surprised that +their code misbehaves when executed. + +The use of the ASCII backslash character in character constants is +an excellent (and still somewhat unresolved) example of this kind of +controversy. +@xref{Backslash in Constants}. +Other examples are likely to arise in the future, as @code{g77} developers +strive to improve its ability to accept an ever-wider variety of existing +Fortran code without requiring significant modifications to said code. + +Development of GNU Fortran is further constrained by the desire +to avoid requiring programmers to change their code. +This is important because it allows programmers, administrators, +and others to more faithfully evaluate and validate @code{g77} +(as an overall product and as new versions are distributed) +without having to support multiple versions of their programs +so that they continue to work the same way on their existing +systems (non-GNU perhaps, but possibly also earlier versions +of @code{g77}). + +@node Standard Support +@section ANSI FORTRAN 77 Standard Support +@cindex ANSI FORTRAN 77 support +@cindex standard support +@cindex support for ANSI FORTRAN 77 +@cindex compatibility, FORTRAN 77 +@cindex FORTRAN 77 compatibility + +GNU Fortran supports ANSI FORTRAN 77 with the following caveats. +In summary, the only ANSI FORTRAN 77 features @code{g77} doesn't +support are those that are probably rarely used in actual code, +some of which are explicitly disallowed by the Fortran 90 standard. + +@menu +* No Passing External Assumed-length:: CHAR*(*) CFUNC restriction. +* No Passing Dummy Assumed-length:: CHAR*(*) CFUNC restriction. +* No Pathological Implied-DO:: No @samp{((@dots{}, I=@dots{}), I=@dots{})}. +* No Useless Implied-DO:: No @samp{(A, I=1, 1)}. +@end menu + +@node No Passing External Assumed-length +@subsection No Passing External Assumed-length + +@code{g77} disallows passing of an external procedure +as an actual argument if the procedure's +type is declared @code{CHARACTER*(*)}. For example: + +@example +CHARACTER*(*) CFUNC +EXTERNAL CFUNC +CALL FOO(CFUNC) +END +@end example + +@noindent +It isn't clear whether the standard considers this conforming. + +@node No Passing Dummy Assumed-length +@subsection No Passing Dummy Assumed-length + +@code{g77} disallows passing of a dummy procedure +as an actual argument if the procedure's +type is declared @code{CHARACTER*(*)}. + +@example +SUBROUTINE BAR(CFUNC) +CHARACTER*(*) CFUNC +EXTERNAL CFUNC +CALL FOO(CFUNC) +END +@end example + +@noindent +It isn't clear whether the standard considers this conforming. + +@node No Pathological Implied-DO +@subsection No Pathological Implied-DO + +The @code{DO} variable for an implied-@code{DO} construct in a +@code{DATA} statement may not be used as the @code{DO} variable +for an outer implied-@code{DO} construct. For example, this +fragment is disallowed by @code{g77}: + +@smallexample +DATA ((A(I, I), I= 1, 10), I= 1, 10) /@dots{}/ +@end smallexample + +@noindent +This also is disallowed by Fortran 90, as it offers no additional +capabilities and would have a variety of possible meanings. + +Note that it is @emph{very} unlikely that any production Fortran code +tries to use this unsupported construct. + +@node No Useless Implied-DO +@subsection No Useless Implied-DO + +An array element initializer in an implied-@code{DO} construct in a +@code{DATA} statement must contain at least one reference to the @code{DO} +variables of each outer implied-@code{DO} construct. For example, +this fragment is disallowed by @code{g77}: + +@smallexample +DATA (A, I= 1, 1) /1./ +@end smallexample + +@noindent +This also is disallowed by Fortran 90, as FORTRAN 77's more permissive +requirements offer no additional capabilities. +However, @code{g77} doesn't necessarily diagnose all cases +where this requirement is not met. + +Note that it is @emph{very} unlikely that any production Fortran code +tries to use this unsupported construct. + +@node Conformance +@section Conformance + +(The following information augments or overrides the information in +Section 1.4 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran +language. +Chapter 1 of that document otherwise serves as the basis +for the relevant aspects of GNU Fortran.) + +The definition of the GNU Fortran language is akin to that of +the ANSI FORTRAN 77 language in that it does not generally require +conforming implementations to diagnose cases where programs do +not conform to the language. + +However, @code{g77} as a compiler is being developed in a way that +is intended to enable it to diagnose such cases in an easy-to-understand +manner. + +A program that conforms to the GNU Fortran language should, when +compiled, linked, and executed using a properly installed @code{g77} +system, perform as described by the GNU Fortran language definition. +Reasons for different behavior include, among others: + +@itemize @bullet +@item +Use of resources (memory---heap, stack, and so on; disk space; CPU +time; etc.) exceeds those of the system. + +@item +Range and/or precision of calculations required by the program +exceeds that of the system. + +@item +Excessive reliance on behaviors that are system-dependent +(non-portable Fortran code). + +@item +Bugs in the program. + +@item +Bug in @code{g77}. + +@item +Bugs in the system. +@end itemize + +Despite these ``loopholes'', the availability of a clear specification +of the language of programs submitted to @code{g77}, as this document +is intended to provide, is considered an important aspect of providing +a robust, clean, predictable Fortran implementation. + +The definition of the GNU Fortran language, while having no special +legal status, can therefore be viewed as a sort of contract, or agreement. +This agreement says, in essence, ``if you write a program in this language, +and run it in an environment (such as a @code{g77} system) that supports +this language, the program should behave in a largely predictable way''. + +@node Notation Used +@section Notation Used in This Chapter + +(The following information augments or overrides the information in +Section 1.5 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran +language. +Chapter 1 of that document otherwise serves as the basis +for the relevant aspects of GNU Fortran.) + +In this chapter, ``must'' denotes a requirement, ``may'' denotes permission, +and ``must not'' and ``may not'' denote prohibition. +Terms such as ``might'', ``should'', and ``can'' generally add little or +nothing in the way of weight to the GNU Fortran language itself, +but are used to explain or illustrate the language. + +For example: + +@display +``The @code{FROBNITZ} statement must precede all executable +statements in a program unit, and may not specify any dummy +arguments. It may specify local or common variables and arrays. +Its use should be limited to portions of the program designed to +be non-portable and system-specific, because it might cause the +containing program unit to behave quite differently on different +systems.'' +@end display + +Insofar as the GNU Fortran language is specified, +the requirements and permissions denoted by the above sample statement +are limited to the placement of the statement and the kinds of +things it may specify. +The rest of the statement---the content regarding non-portable portions +of the program and the differing behavior of program units containing +the @code{FROBNITZ} statement---does not pertain the GNU Fortran +language itself. +That content offers advice and warnings about the @code{FROBNITZ} +statement. + +@emph{Remember:} The GNU Fortran language definition specifies +both what constitutes a valid GNU Fortran program and how, +given such a program, a valid GNU Fortran implementation is +to interpret that program. + +It is @emph{not} incumbent upon a valid GNU Fortran implementation +to behave in any particular way, any consistent way, or any +predictable way when it is asked to interpret input that is +@emph{not} a valid GNU Fortran program. + +Such input is said to have @dfn{undefined} behavior when +interpreted by a valid GNU Fortran implementation, though +an implementation may choose to specify behaviors for some +cases of inputs that are not valid GNU Fortran programs. + +Other notation used herein is that of the GNU texinfo format, +which is used to generate printed hardcopy, on-line hypertext +(Info), and on-line HTML versions, all from a single source +document. +This notation is used as follows: + +@itemize @bullet +@item +Keywords defined by the GNU Fortran language are shown +in uppercase, as in: @code{COMMON}, @code{INTEGER}, and +@code{BLOCK DATA}. + +Note that, in practice, many Fortran programs are written +in lowercase---uppercase is used in this manual as a +means to readily distinguish keywords and sample Fortran-related +text from the prose in this document. + +@item +Portions of actual sample program, input, or output text +look like this: @samp{Actual program text}. + +Generally, uppercase is used for all Fortran-specific and +Fortran-related text, though this does not always include +literal text within Fortran code. + +For example: @samp{PRINT *, 'My name is Bob'}. + +@item +A metasyntactic variable---that is, a name used in this document +to serve as a placeholder for whatever text is used by the +user or programmer--appears as shown in the following example: + +``The @code{INTEGER @var{ivar}} statement specifies that +@var{ivar} is a variable or array of type @code{INTEGER}.'' + +In the above example, any valid text may be substituted for +the metasyntactic variable @var{ivar} to make the statement +apply to a specific instance, as long as the same text is +substituted for @emph{both} occurrences of @var{ivar}. + +@item +Ellipses (``@dots{}'') are used to indicate further text that +is either unimportant or expanded upon further, elsewhere. + +@item +Names of data types are in the style of Fortran 90, in most +cases. + +@xref{Kind Notation}, for information on the relationship +between Fortran 90 nomenclature (such as @code{INTEGER(KIND=1)}) +and the more traditional, less portably concise nomenclature +(such as @code{INTEGER*4}). +@end itemize + +@node Terms and Concepts +@section Fortran Terms and Concepts + +(The following information augments or overrides the information in +Chapter 2 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran +language. +Chapter 2 of that document otherwise serves as the basis +for the relevant aspects of GNU Fortran.) + +@menu +* Syntactic Items:: +* Statements Comments Lines:: +* Scope of Names and Labels:: +@end menu + +@node Syntactic Items +@subsection Syntactic Items + +(Corresponds to Section 2.2 of ANSI X3.9-1978 FORTRAN 77.) + +In GNU Fortran, a symbolic name is at least one character long, +and has no arbitrary upper limit on length. +However, names of entities requiring external linkage (such as +external functions, external subroutines, and @code{COMMON} areas) +might be restricted to some arbitrary length by the system. +Such a restriction is no more constrained than that of one +through six characters. + +Underscores (@samp{_}) are accepted in symbol names after the first +character (which must be a letter). + +@node Statements Comments Lines +@subsection Statements, Comments, and Lines + +(Corresponds to Section 2.3 of ANSI X3.9-1978 FORTRAN 77.) + +@cindex comments, trailing +@cindex trailing comments +Use of an exclamation point (@samp{!}) to begin a +trailing comment (a comment that extends to the end of the same +source line) is permitted under the following conditions: + +@itemize @bullet +@item +The exclamation point does not appear in column 6. +Otherwise, it is treated as an indicator of a continuation +line. + +@item +The exclamation point appears outside a character or hollerith +constant. +Otherwise, the exclamation point is considered part of the +constant. + +@item +The exclamation point appears to the left of any other possible +trailing comment. +That is, a trailing comment may contain exclamation points +in their commentary text. +@end itemize + +@cindex semicolons +@cindex statements, separated by semicolon +Use of a semicolon (@samp{;}) as a statement separator +is permitted under the following conditions: + +@itemize @bullet +@item +The semicolon appears outside a character or hollerith +constant. +Otherwise, the semicolon is considered part of the +constant. + +@item +The semicolon appears to the left of a trailing comment. +Otherwise, the semicolon is considered part of that +comment. + +@item +Neither a logical @code{IF} statement nor a non-construct +@code{WHERE} statement (a Fortran 90 feature) may be +followed (in the same, possibly continued, line) by +a semicolon used as a statement separator. + +This restriction avoids the confusion +that can result when reading a line such as: + +@smallexample +IF (VALIDP) CALL FOO; CALL BAR +@end smallexample + +@noindent +Some readers might think the @samp{CALL BAR} is executed +only if @samp{VALIDP} is @code{.TRUE.}, while others might +assume its execution is unconditional. + +(At present, @code{g77} does not diagnose code that +violates this restriction.) +@end itemize + +@node Scope of Names and Labels +@subsection Scope of Symbolic Names and Statement Labels +@cindex scope + +(Corresponds to Section 2.9 of ANSI X3.9-1978 FORTRAN 77.) + +Included in the list of entities that have a scope of a +program unit are construct names (a Fortran 90 feature). +@xref{Construct Names}, for more information. + +@node Characters Lines Sequence +@section Characters, Lines, and Execution Sequence + +(The following information augments or overrides the information in +Chapter 3 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran +language. +Chapter 3 of that document otherwise serves as the basis +for the relevant aspects of GNU Fortran.) + +@menu +* Character Set:: +* Lines:: +* Continuation Line:: +* Statements:: +* Statement Labels:: +* Order:: +* INCLUDE:: +@end menu + +@node Character Set +@subsection GNU Fortran Character Set +@cindex characters + +(Corresponds to Section 3.1 of ANSI X3.9-1978 FORTRAN 77.) + +Letters include uppercase letters (the twenty-six characters +of the English alphabet) and lowercase letters (their lowercase +equivalent). +Generally, lowercase letters may be used in place of uppercase +letters, though in character and hollerith constants, they +are distinct. + +Special characters include: + +@itemize @bullet +@item +Semicolon (@samp{;}) + +@item +Exclamation point (@samp{!}) + +@item +Double quote (@samp{"}) + +@item +Backslash (@samp{\}) + +@item +Question mark (@samp{?}) + +@item +Hash mark (@samp{#}) + +@item +Ampersand (@samp{&}) + +@item +Percent sign (@samp{%}) + +@item +Underscore (@samp{_}) + +@item +Open angle (@samp{<}) + +@item +Close angle (@samp{>}) + +@item +The FORTRAN 77 special characters (@key{SPC}, @samp{=}, +@samp{+}, @samp{-}, @samp{*}, @samp{/}, @samp{(}, +@samp{)}, @samp{,}, @samp{.}, @samp{$}, @samp{'}, +and @samp{:}) +@end itemize + +@cindex blanks (spaces) +Note that this document refers to @key{SPC} as @dfn{space}, +while X3.9-1978 FORTRAN 77 refers to it as @dfn{blank}. + +@node Lines +@subsection Lines +@cindex lines +@cindex source file format +@cindex source form +@cindex files, source +@cindex source code +@cindex code, source +@cindex fixed form +@cindex free form + +(Corresponds to Section 3.2 of ANSI X3.9-1978 FORTRAN 77.) + +The way a Fortran compiler views source files depends entirely on the +implementation choices made for the compiler, since those choices +are explicitly left to the implementation by the published Fortran +standards. + +The GNU Fortran language mandates a view applicable to UNIX-like +text files---files that are made up of an arbitrary number of lines, +each with an arbitrary number of characters (sometimes called stream-based +files). + +This view does not apply to types of files that are specified as +having a particular number of characters on every single line (sometimes +referred to as record-based files). + +Because a ``line in a program unit is a sequence of 72 characters'', +to quote X3.9-1978, the GNU Fortran language specifies that a +stream-based text file is translated to GNU Fortran lines as follows: + +@itemize @bullet +@item +A newline in the file is the character that represents the end of +a line of text to the underlying system. +For example, on ASCII-based systems, a newline is the @key{NL} +character, which has ASCII value 12 (decimal). + +@item +Each newline in the file serves to end the line of text that precedes +it (and that does not contain a newline). + +@item +The end-of-file marker (@code{EOF}) also serves to end the line +of text that precedes it (and that does not contain a newline). + +@item +@cindex blanks (spaces) +Any line of text that is shorter than 72 characters is padded to that length +with spaces (called ``blanks'' in the standard). + +@item +Any line of text that is longer than 72 characters is truncated to that +length, but the truncated remainder must consist entirely of spaces. + +@item +Characters other than newline and the GNU Fortran character set +are invalid. +@end itemize + +For the purposes of the remainder of this description of the GNU +Fortran language, the translation described above has already +taken place, unless otherwise specified. + +The result of the above translation is that the source file appears, +in terms of the remainder of this description of the GNU Fortran language, +as if it had an arbitrary +number of 72-character lines, each character being among the GNU Fortran +character set. + +For example, if the source file itself has two newlines in a row, +the second newline becomes, after the above translation, a single +line containing 72 spaces. + +@node Continuation Line +@subsection Continuation Line +@cindex continuation lines, number of +@cindex lines, continuation +@cindex number of continuation lines +@cindex limits on continuation lines + +(Corresponds to Section 3.2.3 of ANSI X3.9-1978 FORTRAN 77.) + +A continuation line is any line that both + +@itemize @bullet +@item +Contains a continuation character, and + +@item +Contains only spaces in columns 1 through 5 +@end itemize + +A continuation character is any character of the GNU Fortran character set +other than space (@key{SPC}) or zero (@samp{0}) +in column 6, or a digit (@samp{0} through @samp{9}) in column +7 through 72 of a line that has only spaces to the left of that +digit. + +The continuation character is ignored as far as the content of +the statement is concerned. + +The GNU Fortran language places no limit on the number of +continuation lines in a statement. +In practice, the limit depends on a variety of factors, such as +available memory, statement content, and so on, but no +GNU Fortran system may impose an arbitrary limit. + +@node Statements +@subsection Statements + +(Corresponds to Section 3.3 of ANSI X3.9-1978 FORTRAN 77.) + +Statements may be written using an arbitrary number of continuation +lines. + +Statements may be separated using the semicolon (@samp{;}), except +that the logical @code{IF} and non-construct @code{WHERE} statements +may not be separated from subsequent statements using only a semicolon +as statement separator. + +The @code{END PROGRAM}, @code{END SUBROUTINE}, @code{END FUNCTION}, +and @code{END BLOCK DATA} statements are alternatives to the @code{END} +statement. +These alternatives may be written as normal statements---they are not +subject to the restrictions of the @code{END} statement. + +However, no statement other than @code{END} may have an initial line +that appears to be an @code{END} statement---even @code{END PROGRAM}, +for example, must not be written as: + +@example + END + &PROGRAM +@end example + +@node Statement Labels +@subsection Statement Labels + +(Corresponds to Section 3.4 of ANSI X3.9-1978 FORTRAN 77.) + +A statement separated from its predecessor via a semicolon may be +labeled as follows: + +@itemize @bullet +@item +The semicolon is followed by the label for the statement, +which in turn follows the label. + +@item +The label must be no more than five digits in length. + +@item +The first digit of the label for the statement is not +the first non-space character on a line. +Otherwise, that character is treated as a continuation +character. +@end itemize + +A statement may have only one label defined for it. + +@node Order +@subsection Order of Statements and Lines + +(Corresponds to Section 3.5 of ANSI X3.9-1978 FORTRAN 77.) + +Generally, @code{DATA} statements may precede executable statements. +However, specification statements pertaining to any entities +initialized by a @code{DATA} statement must precede that @code{DATA} +statement. +For example, +after @samp{DATA I/1/}, @samp{INTEGER I} is not permitted, but +@samp{INTEGER J} is permitted. + +The last line of a program unit may be an @code{END} statement, +or may be: + +@itemize @bullet +@item +An @code{END PROGRAM} statement, if the program unit is a main program. + +@item +An @code{END SUBROUTINE} statement, if the program unit is a subroutine. + +@item +An @code{END FUNCTION} statement, if the program unit is a function. + +@item +An @code{END BLOCK DATA} statement, if the program unit is a block data. +@end itemize + +@node INCLUDE +@subsection Including Source Text +@cindex INCLUDE + +Additional source text may be included in the processing of +the source file via the @code{INCLUDE} directive: + +@example +INCLUDE @var{filename} +@end example + +@noindent +The source text to be included is identified by @var{filename}, +which is a literal GNU Fortran character constant. +The meaning and interpretation of @var{filename} depends on the +implementation, but typically is a filename. + +(@code{g77} treats it as a filename that it searches for +in the current directory and/or directories specified +via the @samp{-I} command-line option.) + +The effect of the @code{INCLUDE} directive is as if the +included text directly replaced the directive in the source +file prior to interpretation of the program. +Included text may itself use @code{INCLUDE}. +The depth of nested @code{INCLUDE} references depends on +the implementation, but typically is a positive integer. + +This virtual replacement treats the statements and @code{INCLUDE} +directives in the included text as syntactically distinct from +those in the including text. + +Therefore, the first non-comment line of the included text +must not be a continuation line. +The included text must therefore have, after the non-comment +lines, either an initial line (statement), an @code{INCLUDE} +directive, or nothing (the end of the included text). + +Similarly, the including text may end the @code{INCLUDE} +directive with a semicolon or the end of the line, but it +cannot follow an @code{INCLUDE} directive at the end of its +line with a continuation line. +Thus, the last statement in an included text may not be +continued. + +Any statements between two @code{INCLUDE} directives on the +same line are treated as if they appeared in between the +respective included texts. +For example: + +@smallexample +INCLUDE 'A'; PRINT *, 'B'; INCLUDE 'C'; END PROGRAM +@end smallexample + +@noindent +If the text included by @samp{INCLUDE 'A'} constitutes +a @samp{PRINT *, 'A'} statement and the text included by +@samp{INCLUDE 'C'} constitutes a @samp{PRINT *, 'C'} statement, +then the output of the above sample program would be + +@example +A +B +C +@end example + +@noindent +(with suitable allowances for how an implementation defines +its handling of output). + +Included text must not include itself directly or indirectly, +regardless of whether the @var{filename} used to reference +the text is the same. + +Note that @code{INCLUDE} is @emph{not} a statement. +As such, it is neither a non-executable or executable +statement. +However, if the text it includes constitutes one or more +executable statements, then the placement of @code{INCLUDE} +is subject to effectively the same restrictions as those +on executable statements. + +An @code{INCLUDE} directive may be continued across multiple +lines as if it were a statement. +This permits long names to be used for @var{filename}. + +@node Data Types and Constants +@section Data Types and Constants + +(The following information augments or overrides the information in +Chapter 4 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran +language. +Chapter 4 of that document otherwise serves as the basis +for the relevant aspects of GNU Fortran.) + +To more concisely express the appropriate types for +entities, this document uses the more concise +Fortran 90 nomenclature such as @code{INTEGER(KIND=1)} +instead of the more traditional, but less portably concise, +byte-size-based nomenclature such as @code{INTEGER*4}, +wherever reasonable. + +When referring to generic types---in contexts where the +specific precision and range of a type are not important---this +document uses the generic type names @code{INTEGER}, @code{LOGICAL}, +@code{REAL}, @code{COMPLEX}, and @code{CHARACTER}. + +In some cases, the context requires specification of a +particular type. +This document uses the @samp{KIND=} notation to accomplish +this throughout, sometimes supplying the more traditional +notation for clarification, though the traditional notation +might not work the same way on all GNU Fortran implementations. + +Use of @samp{KIND=} makes this document more concise because +@code{g77} is able to define values for @samp{KIND=} that +have the same meanings on all systems, due to the way the +Fortran 90 standard specifies these values are to be used. + +(In particular, that standard permits an implementation to +arbitrarily assign nonnegative values. +There are four distinct sets of assignments: one to the @code{CHARACTER} +type; one to the @code{INTEGER} type; one to the @code{LOGICAL} type; +and the fourth to both the @code{REAL} and @code{COMPLEX} types. +Implementations are free to assign these values in any order, +leave gaps in the ordering of assignments, and assign more than +one value to a representation.) + +This makes @samp{KIND=} values superior to the values used +in non-standard statements such as @samp{INTEGER*4}, because +the meanings of the values in those statements vary from machine +to machine, compiler to compiler, even operating system to +operating system. + +However, use of @samp{KIND=} is @emph{not} generally recommended +when writing portable code (unless, for example, the code is +going to be compiled only via @code{g77}, which is a widely +ported compiler). +GNU Fortran does not yet have adequate language constructs to +permit use of @samp{KIND=} in a fashion that would make the +code portable to Fortran 90 implementations; and, this construct +is known to @emph{not} be accepted by many popular FORTRAN 77 +implementations, so it cannot be used in code that is to be ported +to those. + +The distinction here is that this document is able to use +specific values for @samp{KIND=} to concisely document the +types of various operations and operands. + +A Fortran program should use the FORTRAN 77 designations for the +appropriate GNU Fortran types---such as @code{INTEGER} for +@code{INTEGER(KIND=1)}, @code{REAL} for @code{REAL(KIND=1)}, +and @code{DOUBLE COMPLEX} for @code{COMPLEX(KIND=2)}---and, +where no such designations exist, make use of appropriate +techniques (preprocessor macros, parameters, and so on) +to specify the types in a fashion that may be easily adjusted +to suit each particular implementation to which the program +is ported. +(These types generally won't need to be adjusted for ports of +@code{g77}.) + +Further details regarding GNU Fortran data types and constants +are provided below. + +@menu +* Types:: +* Constants:: +* Integer Type:: +* Character Type:: +@end menu + +@node Types +@subsection Data Types + +(Corresponds to Section 4.1 of ANSI X3.9-1978 FORTRAN 77.) + +GNU Fortran supports these types: + +@enumerate +@item +Integer (generic type @code{INTEGER}) + +@item +Real (generic type @code{REAL}) + +@item +Double precision + +@item +Complex (generic type @code{COMPLEX}) + +@item +Logical (generic type @code{LOGICAL}) + +@item +Character (generic type @code{CHARACTER}) + +@item +Double Complex +@end enumerate + +(The types numbered 1 through 6 above are standard FORTRAN 77 types.) + +The generic types shown above are referred to in this document +using only their generic type names. +Such references usually indicate that any specific type (kind) +of that generic type is valid. + +For example, a context described in this document as accepting +the @code{COMPLEX} type also is likely to accept the +@code{DOUBLE COMPLEX} type. + +The GNU Fortran language supports three ways to specify +a specific kind of a generic type. + +@menu +* Double Notation:: As in @code{DOUBLE COMPLEX}. +* Star Notation:: As in @code{INTEGER*4}. +* Kind Notation:: As in @code{INTEGER(KIND=1)}. +@end menu + +@node Double Notation +@subsubsection Double Notation + +The GNU Fortran language supports two uses of the keyword +@code{DOUBLE} to specify a specific kind of type: + +@itemize @bullet +@item +@code{DOUBLE PRECISION}, equivalent to @code{REAL(KIND=2)} + +@item +@code{DOUBLE COMPLEX}, equivalent to @code{COMPLEX(KIND=2)} +@end itemize + +Use one of the above forms where a type name is valid. + +While use of this notation is popular, it doesn't scale +well in a language or dialect rich in intrinsic types, +as is the case for the GNU Fortran language (especially +planned future versions of it). + +After all, one rarely sees type names such as @samp{DOUBLE INTEGER}, +@samp{QUADRUPLE REAL}, or @samp{QUARTER INTEGER}. +Instead, @code{INTEGER*8}, @code{REAL*16}, and @code{INTEGER*1} +often are substituted for these, respectively, even though they +do not always have the same meanings on all systems. +(And, the fact that @samp{DOUBLE REAL} does not exist as such +is an inconsistency.) + +Therefore, this document uses ``double notation'' only on occasion +for the benefit of those readers who are accustomed to it. + +@node Star Notation +@subsubsection Star Notation +@cindex *@var{n} notation + +The following notation specifies the storage size for a type: + +@smallexample +@var{generic-type}*@var{n} +@end smallexample + +@noindent +@var{generic-type} must be a generic type---one of +@code{INTEGER}, @code{REAL}, @code{COMPLEX}, @code{LOGICAL}, +or @code{CHARACTER}. +@var{n} must be one or more digits comprising a decimal +integer number greater than zero. + +Use the above form where a type name is valid. + +The @samp{*@var{n}} notation specifies that the amount of storage +occupied by variables and array elements of that type is @var{n} +times the storage occupied by a @code{CHARACTER*1} variable. + +This notation might indicate a different degree of precision and/or +range for such variables and array elements, and the functions that +return values of types using this notation. +It does not limit the precision or range of values of that type +in any particular way---use explicit code to do that. + +Further, the GNU Fortran language requires no particular values +for @var{n} to be supported by an implementation via the @samp{*@var{n}} +notation. +@code{g77} supports @code{INTEGER*1} (as @code{INTEGER(KIND=3)}) +on all systems, for example, +but not all implementations are required to do so, and @code{g77} +is known to not support @code{REAL*1} on most (or all) systems. + +As a result, except for @var{generic-type} of @code{CHARACTER}, +uses of this notation should be limited to isolated +portions of a program that are intended to handle system-specific +tasks and are expected to be non-portable. + +(Standard FORTRAN 77 supports the @samp{*@var{n}} notation for +only @code{CHARACTER}, where it signifies not only the amount +of storage occupied, but the number of characters in entities +of that type. +However, almost all Fortran compilers have supported this +notation for generic types, though with a variety of meanings +for @var{n}.) + +Specifications of types using the @samp{*@var{n}} notation +always are interpreted as specifications of the appropriate +types described in this document using the @samp{KIND=@var{n}} +notation, described below. + +While use of this notation is popular, it doesn't serve well +in the context of a widely portable dialect of Fortran, such as +the GNU Fortran language. + +For example, even on one particular machine, two or more popular +Fortran compilers might well disagree on the size of a type +declared @code{INTEGER*2} or @code{REAL*16}. +Certainly there +is known to be disagreement over such things among Fortran +compilers on @emph{different} systems. + +Further, this notation offers no elegant way to specify sizes +that are not even multiples of the ``byte size'' typically +designated by @code{INTEGER*1}. +Use of ``absurd'' values (such as @code{INTEGER*1000}) would +certainly be possible, but would perhaps be stretching the original +intent of this notation beyond the breaking point in terms +of widespread readability of documentation and code making use +of it. + +Therefore, this document uses ``star notation'' only on occasion +for the benefit of those readers who are accustomed to it. + +@node Kind Notation +@subsubsection Kind Notation +@cindex KIND= notation + +The following notation specifies the kind-type selector of a type: + +@smallexample +@var{generic-type}(KIND=@var{n}) +@end smallexample + +@noindent +Use the above form where a type name is valid. + +@var{generic-type} must be a generic type---one of +@code{INTEGER}, @code{REAL}, @code{COMPLEX}, @code{LOGICAL}, +or @code{CHARACTER}. +@var{n} must be an integer initialization expression that +is a positive, nonzero value. + +Programmers are discouraged from writing these values directly +into their code. +Future versions of the GNU Fortran language will offer +facilities that will make the writing of code portable +to @code{g77} @emph{and} Fortran 90 implementations simpler. + +However, writing code that ports to existing FORTRAN 77 +implementations depends on avoiding the @samp{KIND=} construct. + +The @samp{KIND=} construct is thus useful in the context +of GNU Fortran for two reasons: + +@itemize @bullet +@item +It provides a means to specify a type in a fashion that +is portable across all GNU Fortran implementations (though +not other FORTRAN 77 and Fortran 90 implementations). + +@item +It provides a sort of Rosetta stone for this document to use +to concisely describe the types of various operations and +operands. +@end itemize + +The values of @var{n} in the GNU Fortran language are +assigned using a scheme that: + +@itemize @bullet +@item +Attempts to maximize the ability of readers +of this document to quickly familiarize themselves +with assignments for popular types + +@item +Provides a unique value for each specific desired +meaning + +@item +Provides a means to automatically assign new values so +they have a ``natural'' relationship to existing values, +if appropriate, or, if no such relationship exists, will +not interfere with future values assigned on the basis +of such relationships + +@item +Avoids using values that are similar to values used +in the existing, popular @samp{*@var{n}} notation, +to prevent readers from expecting that these implied +correspondences work on all GNU Fortran implementations +@end itemize + +The assignment system accomplishes this by assigning +to each ``fundamental meaning'' of a specific type a +unique prime number. +Combinations of fundamental meanings---for example, a type +that is two times the size of some other type---are assigned +values of @var{n} that are the products of the values for +those fundamental meanings. + +A prime value of @var{n} is never given more than one fundamental +meaning, to avoid situations where some code or system +cannot reasonably provide those meanings in the form of a +single type. + +The values of @var{n} assigned so far are: + +@table @code +@item KIND=0 +This value is reserved for future use. + +The planned future use is for this value to designate, +explicitly, context-sensitive kind-type selection. +For example, the expression @samp{1D0 * 0.1_0} would +be equivalent to @samp{1D0 * 0.1D0}. + +@item KIND=1 +This corresponds to the default types for +@code{REAL}, @code{INTEGER}, @code{LOGICAL}, @code{COMPLEX}, +and @code{CHARACTER}, as appropriate. + +These are the ``default'' types described in the Fortran 90 standard, +though that standard does not assign any particular @samp{KIND=} +value to these types. + +(Typically, these are @code{REAL*4}, @code{INTEGER*4}, +@code{LOGICAL*4}, and @code{COMPLEX*8}.) + +@item KIND=2 +This corresponds to types that occupy twice as much +storage as the default types. +@code{REAL(KIND=2)} is @code{DOUBLE PRECISION} (typically @code{REAL*8}), +@code{COMPLEX(KIND=2)} is @code{DOUBLE COMPLEX} (typically @code{COMPLEX*16}), + +These are the ``double precision'' types described in the Fortran 90 +standard, +though that standard does not assign any particular @samp{KIND=} +value to these types. + +@var{n} of 4 thus corresponds to types that occupy four times +as much storage as the default types, @var{n} of 8 to types that +occupy eight times as much storage, and so on. + +The @code{INTEGER(KIND=2)} and @code{LOGICAL(KIND=2)} types +are not necessarily supported by every GNU Fortran implementation. + +@item KIND=3 +This corresponds to types that occupy as much +storage as the default @code{CHARACTER} type, +which is the same effective type as @code{CHARACTER(KIND=1)} +(making that type effectively the same as @code{CHARACTER(KIND=3)}). + +(Typically, these are @code{INTEGER*1} and @code{LOGICAL*1}.) + +@var{n} of 6 thus corresponds to types that occupy twice as +much storage as the @var{n}=3 types, @var{n} of 12 to types +that occupy four times as much storage, and so on. + +These are not necessarily supported by every GNU Fortran +implementation. + +@item KIND=5 +This corresponds to types that occupy half the +storage as the default (@var{n}=1) types. + +(Typically, these are @code{INTEGER*2} and @code{LOGICAL*2}.) + +@var{n} of 25 thus corresponds to types that occupy one-quarter +as much storage as the default types. + +These are not necessarily supported by every GNU Fortran +implementation. + +@item KIND=7 +This is valid only as @code{INTEGER(KIND=7)} and +denotes the @code{INTEGER} type that has the smallest +storage size that holds a pointer on the system. + +A pointer representable by this type is capable of uniquely +addressing a @code{CHARACTER*1} variable, array, array element, +or substring. + +(Typically this is equivalent to @code{INTEGER*4} or, +on 64-bit systems, @code{INTEGER*8}. +In a compatible C implementation, it typically would +be the same size and semantics of the C type @code{void *}.) +@end table + +Note that these are @emph{proposed} correspondences and might change +in future versions of @code{g77}---avoid writing code depending +on them while @code{g77}, and therefore the GNU Fortran language +it defines, is in beta testing. + +Values not specified in the above list are reserved to +future versions of the GNU Fortran language. + +Implementation-dependent meanings will be assigned new, +unique prime numbers so as to not interfere with other +implementation-dependent meanings, and offer the possibility +of increasing the portability of code depending on such +types by offering support for them in other GNU Fortran +implementations. + +Other meanings that might be given unique values are: + +@itemize @bullet +@item +Types that make use of only half their storage size for +representing precision and range. + +For example, some compilers offer options that cause +@code{INTEGER} types to occupy the amount of storage +that would be needed for @code{INTEGER(KIND=2)} types, but the +range remains that of @code{INTEGER(KIND=1)}. + +@item +The IEEE single floating-point type. + +@item +Types with a specific bit pattern (endianness), such as the +little-endian form of @code{INTEGER(KIND=1)}. +These could permit, conceptually, use of portable code and +implementations on data files written by existing systems. +@end itemize + +Future @emph{prime} numbers should be given meanings in as incremental +a fashion as possible, to allow for flexibility and +expressiveness in combining types. + +For example, instead of defining a prime number for little-endian +IEEE doubles, one prime number might be assigned the meaning +``little-endian'', another the meaning ``IEEE double'', and the +value of @var{n} for a little-endian IEEE double would thus +naturally be the product of those two respective assigned values. +(It could even be reasonable to have IEEE values result from the +products of prime values denoting exponent and fraction sizes +and meanings, hidden bit usage, availability and representations +of special values such as subnormals, infinities, and Not-A-Numbers +(NaNs), and so on.) + +This assignment mechanism, while not inherently required for +future versions of the GNU Fortran language, is worth using +because it could ease management of the ``space'' of supported +types much easier in the long run. + +The above approach suggests a mechanism for specifying inheritance +of intrinsic (built-in) types for an entire, widely portable +product line. +It is certainly reasonable that, unlike programmers of other languages +offering inheritance mechanisms that employ verbose names for classes +and subclasses, along with graphical browsers to elucidate the +relationships, Fortran programmers would employ +a mechanism that works by multiplying prime numbers together +and finding the prime factors of such products. + +Most of the advantages for the above scheme have been explained +above. +One disadvantage is that it could lead to the defining, +by the GNU Fortran language, of some fairly large prime numbers. +This could lead to the GNU Fortran language being declared +``munitions'' by the United States Department of Defense. + +@node Constants +@subsection Constants +@cindex constants +@cindex types, constants + +(Corresponds to Section 4.2 of ANSI X3.9-1978 FORTRAN 77.) + +A @dfn{typeless constant} has one of the following forms: + +@smallexample +'@var{binary-digits}'B +'@var{octal-digits}'O +'@var{hexadecimal-digits}'Z +'@var{hexadecimal-digits}'X +@end smallexample + +@noindent +@var{binary-digits}, @var{octal-digits}, and @var{hexadecimal-digits} +are nonempty strings of characters in the set @samp{01}, @samp{01234567}, +and @samp{0123456789ABCDEFabcdef}, respectively. +(The value for @samp{A} (and @samp{a}) is 10, for @samp{B} and @samp{b} +is 11, and so on.) + +Typeless constants have values that depend on the context in which +they are used. + +All other constants, called @dfn{typed constants}, are interpreted---converted +to internal form---according to their inherent type. +Thus, context is @emph{never} a determining factor for the type, and hence +the interpretation, of a typed constant. +(All constants in the ANSI FORTRAN 77 language are typed constants.) + +For example, @samp{1} is always type @code{INTEGER(KIND=1)} in GNU +Fortran (called default INTEGER in Fortran 90), +@samp{9.435784839284958} is always type @code{REAL(KIND=1)} (even if the +additional precision specified is lost, and even when used in a +@code{REAL(KIND=2)} context), @samp{1E0} is always type @code{REAL(KIND=2)}, +and @samp{1D0} is always type @code{REAL(KIND=2)}. + +@node Integer Type +@subsection Integer Type + +(Corresponds to Section 4.3 of ANSI X3.9-1978 FORTRAN 77.) + +An integer constant also may have one of the following forms: + +@smallexample +B'@var{binary-digits}' +O'@var{octal-digits}' +Z'@var{hexadecimal-digits}' +X'@var{hexadecimal-digits}' +@end smallexample + +@noindent +@var{binary-digits}, @var{octal-digits}, and @var{hexadecimal-digits} +are nonempty strings of characters in the set @samp{01}, @samp{01234567}, +and @samp{0123456789ABCDEFabcdef}, respectively. +(The value for @samp{A} (and @samp{a}) is 10, for @samp{B} and @samp{b} +is 11, and so on.) + +@node Character Type +@subsection Character Type + +(Corresponds to Section 4.8 of ANSI X3.9-1978 FORTRAN 77.) + +A character constant may be delimited by a pair of double quotes +(@samp{"}) instead of apostrophes. +In this case, an apostrophe within the constant represents +a single apostrophe, while a double quote is represented in +the source text of the constant by two consecutive double +quotes with no intervening spaces. + +@cindex zero-length CHARACTER +@cindex null CHARACTER strings +@cindex empty CHARACTER strings +@cindex strings, empty +@cindex CHARACTER, null +A character constant may be empty (have a length of zero). + +A character constant may include a substring specification, +The value of such a constant is the value of the substring---for +example, the value of @samp{'hello'(3:5)} is the same +as the value of @samp{'llo'}. + +@node Expressions +@section Expressions + +(The following information augments or overrides the information in +Chapter 6 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran +language. +Chapter 6 of that document otherwise serves as the basis +for the relevant aspects of GNU Fortran.) + +@menu +* %LOC():: +@end menu + +@node %LOC() +@subsection The @code{%LOC()} Construct +@cindex %LOC() construct + +@example +%LOC(@var{arg}) +@end example + +The @code{%LOC()} construct is an expression +that yields the value of the location of its argument, +@var{arg}, in memory. +The size of the type of the expression depends on the system---typically, +it is equivalent to either @code{INTEGER(KIND=1)} or @code{INTEGER(KIND=2)}, +though it is actually type @code{INTEGER(KIND=7)}. + +The argument to @code{%LOC()} must be suitable as the +left-hand side of an assignment statement. +That is, it may not be a general expression involving +operators such as addition, subtraction, and so on, +nor may it be a constant. + +Use of @code{%LOC()} is recommended only for code that +is accessing facilities outside of GNU Fortran, such as +operating system or windowing facilities. +It is best to constrain such uses to isolated portions of +a program---portions that deal specifically and exclusively +with low-level, system-dependent facilities. +Such portions might well provide a portable interface for +use by the program as a whole, but are themselves not +portable, and should be thoroughly tested each time they +are rebuilt using a new compiler or version of a compiler. + +Do not depend on @code{%LOC()} returning a pointer that +can be safely used to @emph{define} (change) the argument. +While this might work in some circumstances, it is hard +to predict whether it will continue to work when a program +(that works using this unsafe behavior) +is recompiled using different command-line options or +a different version of @code{g77}. + +Generally, @code{%LOC()} is safe when used as an argument +to a procedure that makes use of the value of the corresponding +dummy argument only during its activation, and only when +such use is restricted to referencing (reading) the value +of the argument to @code{%LOC()}. + +@emph{Implementation Note:} Currently, @code{g77} passes +arguments (those not passed using a construct such as @code{%VAL()}) +by reference or descriptor, depending on the type of +the actual argument. +Thus, given @samp{INTEGER I}, @samp{CALL FOO(I)} would +seem to mean the same thing as @samp{CALL FOO(%LOC(I))}, and +in fact might compile to identical code. + +However, @samp{CALL FOO(%LOC(I))} emphatically means ``pass the +address of @samp{I} in memory''. +While @samp{CALL FOO(I)} might use that same approach in a +particular version of @code{g77}, another version or compiler +might choose a different implementation, such as copy-in/copy-out, +to effect the desired behavior---and which will therefore not +necessarily compile to the same code as would @samp{CALL FOO(%LOC(I))} +using the same version or compiler. + +@xref{Debugging and Interfacing}, for detailed information on +how this particular version of @code{g77} implements various +constructs. + +@node Specification Statements +@section Specification Statements + +(The following information augments or overrides the information in +Chapter 8 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran +language. +Chapter 8 of that document otherwise serves as the basis +for the relevant aspects of GNU Fortran.) + +@menu +* NAMELIST:: +* DOUBLE COMPLEX:: +@end menu + +@node NAMELIST +@subsection @code{NAMELIST} Statement +@cindex NAMELIST statement +@cindex statements, NAMELIST + +The @code{NAMELIST} statement, and related I/O constructs, are +supported by the GNU Fortran language in essentially the same +way as they are by @code{f2c}. + +@node DOUBLE COMPLEX +@subsection @code{DOUBLE COMPLEX} Statement +@cindex DOUBLE COMPLEX + +@code{DOUBLE COMPLEX} is a type-statement (and type) that +specifies the type @code{COMPLEX(KIND=2)} in GNU Fortran. + +@node Control Statements +@section Control Statements + +(The following information augments or overrides the information in +Chapter 11 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran +language. +Chapter 11 of that document otherwise serves as the basis +for the relevant aspects of GNU Fortran.) + +@menu +* DO WHILE:: +* END DO:: +* Construct Names:: +* CYCLE and EXIT:: +@end menu + +@node DO WHILE +@subsection DO WHILE +@cindex DO WHILE +@cindex MIL-STD 1753 + +The @code{DO WHILE} statement, a feature of both the MIL-STD 1753 and +Fortran 90 standards, is provided by the GNU Fortran language. + +@node END DO +@subsection END DO +@cindex END DO +@cindex MIL-STD 1753 + +The @code{END DO} statement is provided by the GNU Fortran language. + +This statement is used in one of two ways: + +@itemize @bullet +@item +The Fortran 90 meaning, in which it specifies the termination +point of a single @code{DO} loop started with a @code{DO} statement +that specifies no termination label. + +@item +The MIL-STD 1753 meaning, in which it specifies the termination +point of one or more @code{DO} loops, all of which start with a +@code{DO} statement that specify the label defined for the +@code{END DO} statement. + +This kind of @code{END DO} statement is merely a synonym for +@code{CONTINUE}, except it is permitted only when the statement +is labeled and a target of one or more labeled @code{DO} loops. + +It is expected that this use of @code{END DO} will be removed from +the GNU Fortran language in the future, though it is likely that +it will long be supported by @code{g77} as a dialect form. +@end itemize + +@node Construct Names +@subsection Construct Names +@cindex construct names + +The GNU Fortran language supports construct names as defined +by the Fortran 90 standard. +These names are local to the program unit and are defined +as follows: + +@smallexample +@var{construct-name}: @var{block-statement} +@end smallexample + +@noindent +Here, @var{construct-name} is the construct name itself; +its definition is connoted by the single colon (@samp{:}); and +@var{block-statement} is an @code{IF}, @code{DO}, +or @code{SELECT CASE} statement that begins a block. + +A block that is given a construct name must also specify the +same construct name in its termination statement: + +@example +END @var{block} @var{construct-name} +@end example + +@noindent +Here, @var{block} must be @code{IF}, @code{DO}, or @code{SELECT}, +as appropriate. + +@node CYCLE and EXIT +@subsection The @code{CYCLE} and @code{EXIT} Statements + +The @code{CYCLE} and @code{EXIT} statements specify that +the remaining statements in the current iteration of a +particular active (enclosing) @code{DO} loop are to be skipped. + +@code{CYCLE} specifies that these statements are skipped, +but the @code{END DO} statement that marks the end of the +@code{DO} loop be executed---that is, the next iteration, +if any, is to be started. +If the statement marking the end of the @code{DO} loop is +not @code{END DO}---in other words, if the loop is not +a block @code{DO}---the @code{CYCLE} statement does not +execute that statement, but does start the next iteration (if any). + +@code{EXIT} specifies that the loop specified by the +@code{DO} construct is terminated. + +The @code{DO} loop affected by @code{CYCLE} and @code{EXIT} +is the innermost enclosing @code{DO} loop when the following +forms are used: + +@example +CYCLE +EXIT +@end example + +Otherwise, the following forms specify the construct name +of the pertinent @code{DO} loop: + +@example +CYCLE @var{construct-name} +EXIT @var{construct-name} +@end example + +@code{CYCLE} and @code{EXIT} can be viewed as glorified @code{GO TO} +statements. +However, they cannot be easily thought of as @code{GO TO} statements +in obscure cases involving FORTRAN 77 loops. +For example: + +@smallexample + DO 10 I = 1, 5 + DO 10 J = 1, 5 + IF (J .EQ. 5) EXIT + DO 10 K = 1, 5 + IF (K .EQ. 3) CYCLE +10 PRINT *, 'I=', I, ' J=', J, ' K=', K +20 CONTINUE +@end smallexample + +@noindent +In particular, neither the @code{EXIT} nor @code{CYCLE} statements +above are equivalent to a @code{GO TO} statement to either label +@samp{10} or @samp{20}. + +To understand the effect of @code{CYCLE} and @code{EXIT} in the +above fragment, it is helpful to first translate it to its equivalent +using only block @code{DO} loops: + +@smallexample + DO I = 1, 5 + DO J = 1, 5 + IF (J .EQ. 5) EXIT + DO K = 1, 5 + IF (K .EQ. 3) CYCLE +10 PRINT *, 'I=', I, ' J=', J, ' K=', K + END DO + END DO + END DO +20 CONTINUE +@end smallexample + +Adding new labels allows translation of @code{CYCLE} and @code{EXIT} +to @code{GO TO} so they may be more easily understood by programmers +accustomed to FORTRAN coding: + +@smallexample + DO I = 1, 5 + DO J = 1, 5 + IF (J .EQ. 5) GOTO 18 + DO K = 1, 5 + IF (K .EQ. 3) GO TO 12 +10 PRINT *, 'I=', I, ' J=', J, ' K=', K +12 END DO + END DO +18 END DO +20 CONTINUE +@end smallexample + +@noindent +Thus, the @code{CYCLE} statement in the innermost loop skips over +the @code{PRINT} statement as it begins the next iteration of the +loop, while the @code{EXIT} statement in the middle loop ends that +loop but @emph{not} the outermost loop. + +@node Functions and Subroutines +@section Functions and Subroutines + +(The following information augments or overrides the information in +Chapter 15 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran +language. +Chapter 15 of that document otherwise serves as the basis +for the relevant aspects of GNU Fortran.) + +@menu +* %VAL():: +* %REF():: +* %DESCR():: +* Generics and Specifics:: +* REAL() and AIMAG() of Complex:: +* CMPLX() of DOUBLE PRECISION:: +* MIL-STD 1753:: +* f77/f2c Intrinsics:: +* Table of Intrinsic Functions:: +@end menu + +@node %VAL() +@subsection The @code{%VAL()} Construct +@cindex %VAL() construct + +@example +%VAL(@var{arg}) +@end example + +The @code{%VAL()} construct specifies that an argument, +@var{arg}, is to be passed by value, instead of by reference +or descriptor. + +@code{%VAL()} is restricted to actual arguments in +invocations of external procedures. + +Use of @code{%VAL()} is recommended only for code that +is accessing facilities outside of GNU Fortran, such as +operating system or windowing facilities. +It is best to constrain such uses to isolated portions of +a program---portions the deal specifically and exclusively +with low-level, system-dependent facilities. +Such portions might well provide a portable interface for +use by the program as a whole, but are themselves not +portable, and should be thoroughly tested each time they +are rebuilt using a new compiler or version of a compiler. + +@emph{Implementation Note:} Currently, @code{g77} passes +all arguments either by reference or by descriptor. + +Thus, use of @code{%VAL()} tends to be restricted to cases +where the called procedure is written in a language other +than Fortran that supports call-by-value semantics. +(C is an example of such a language.) + +@xref{Procedures,,Procedures (SUBROUTINE and FUNCTION)}, +for detailed information on +how this particular version of @code{g77} passes arguments +to procedures. + +@node %REF() +@subsection The @code{%REF()} Construct +@cindex %REF() construct + +@example +%REF(@var{arg}) +@end example + +The @code{%REF()} construct specifies that an argument, +@var{arg}, is to be passed by reference, instead of by +value or descriptor. + +@code{%REF()} is restricted to actual arguments in +invocations of external procedures. + +Use of @code{%REF()} is recommended only for code that +is accessing facilities outside of GNU Fortran, such as +operating system or windowing facilities. +It is best to constrain such uses to isolated portions of +a program---portions the deal specifically and exclusively +with low-level, system-dependent facilities. +Such portions might well provide a portable interface for +use by the program as a whole, but are themselves not +portable, and should be thoroughly tested each time they +are rebuilt using a new compiler or version of a compiler. + +Do not depend on @code{%REF()} supplying a pointer to the +procedure being invoked. +While that is a likely implementation choice, other +implementation choices are available that preserve Fortran +pass-by-reference semantics without passing a pointer to +the argument, @var{arg}. +(For example, a copy-in/copy-out implementation.) + +@emph{Implementation Note:} Currently, @code{g77} passes +all arguments +(other than variables and arrays of type @code{CHARACTER}) +by reference. +Future versions of, or dialects supported by, @code{g77} might +not pass @code{CHARACTER} functions by reference. + +Thus, use of @code{%REF()} tends to be restricted to cases +where @var{arg} is type @code{CHARACTER} but the called +procedure accesses it via a means other than the method +used for Fortran @code{CHARACTER} arguments. + +@xref{Procedures,,Procedures (SUBROUTINE and FUNCTION)}, for detailed information on +how this particular version of @code{g77} passes arguments +to procedures. + +@node %DESCR() +@subsection The @code{%DESCR()} Construct +@cindex %DESCR() construct + +@example +%DESCR(@var{arg}) +@end example + +The @code{%DESCR()} construct specifies that an argument, +@var{arg}, is to be passed by descriptor, instead of by +value or reference. + +@code{%DESCR()} is restricted to actual arguments in +invocations of external procedures. + +Use of @code{%DESCR()} is recommended only for code that +is accessing facilities outside of GNU Fortran, such as +operating system or windowing facilities. +It is best to constrain such uses to isolated portions of +a program---portions the deal specifically and exclusively +with low-level, system-dependent facilities. +Such portions might well provide a portable interface for +use by the program as a whole, but are themselves not +portable, and should be thoroughly tested each time they +are rebuilt using a new compiler or version of a compiler. + +Do not depend on @code{%DESCR()} supplying a pointer +and/or a length passed by value +to the procedure being invoked. +While that is a likely implementation choice, other +implementation choices are available that preserve the +pass-by-reference semantics without passing a pointer to +the argument, @var{arg}. +(For example, a copy-in/copy-out implementation.)@ +And, future versions of @code{g77} might change the +way descriptors are implemented, such as passing a +single argument pointing to a record containing the +pointer/length information instead of passing that same +information via two arguments as it currently does. + +@emph{Implementation Note:} Currently, @code{g77} passes +all variables and arrays of type @code{CHARACTER} +by descriptor. +Future versions of, or dialects supported by, @code{g77} might +pass @code{CHARACTER} functions by descriptor as well. + +Thus, use of @code{%DESCR()} tends to be restricted to cases +where @var{arg} is not type @code{CHARACTER} but the called +procedure accesses it via a means similar to the method +used for Fortran @code{CHARACTER} arguments. + +@xref{Procedures,,Procedures (SUBROUTINE and FUNCTION)}, for detailed information on +how this particular version of @code{g77} passes arguments +to procedures. + +@node Generics and Specifics +@subsection Generics and Specifics +@cindex generic intrinsics +@cindex intrinsics, generic + +The ANSI FORTRAN 77 language defines generic and specific +intrinsics. +In short, the distinctions are: + +@itemize @bullet +@item +@emph{Specific} intrinsics have +specific types for their arguments and a specific return +type. + +@item +@emph{Generic} intrinsics are treated, +on a case-by-case basis in the program's source code, +as one of several possible specific intrinsics. + +Typically, a generic intrinsic has a return type that +is determined by the type of one or more of its arguments. +@end itemize + +The GNU Fortran language generalizes these concepts somewhat, +especially by providing intrinsic subroutines and generic +intrinsics that are treated as either a specific intrinsic subroutine +or a specific intrinsic function (e.g. @code{SECOND}). + +However, GNU Fortran avoids generalizing this concept to +the point where existing code would be accepted as meaning +something possibly different than what was intended. + +For example, @code{ABS} is a generic intrinsic, so all working +code written using @code{ABS} of an @code{INTEGER} argument +expects an @code{INTEGER} return value. +Similarly, all such code expects that @code{ABS} of an @code{INTEGER*2} +argument returns an @code{INTEGER*2} return value. + +Yet, @code{IABS} is a @emph{specific} intrinsic that accepts only +an @code{INTEGER(KIND=1)} argument. +Code that passes something other than an @code{INTEGER(KIND=1)} +argument to @code{IABS} is not valid GNU Fortran code, because +it is not clear what the author intended. + +For example, if @samp{J} is @code{INTEGER(KIND=6)}, @samp{IABS(J)} +is not defined by the GNU Fortran language, because the programmer +might have used that construct to mean any of the following, subtly +different, things: + +@itemize @bullet +@item +Convert @samp{J} to @code{INTEGER(KIND=1)} first +(as if @samp{IABS(INT(J))} had been written). + +@item +Convert the result of the intrinsic to @code{INTEGER(KIND=1)} +(as if @samp{INT(ABS(J))} had been written). + +@item +No conversion (as if @samp{ABS(J)} had been written). +@end itemize + +The distinctions matter especially when types and values wider than +@code{INTEGER(KIND=1)} (such as @code{INTEGER(KIND=2)}), or when +operations performing more ``arithmetic'' than absolute-value, are involved. + +The following sample program is not a valid GNU Fortran program, but +might be accepted by other compilers. +If so, the output is likely to be revealing in terms of how a given +compiler treats intrinsics (that normally are specific) when they +are given arguments that do not conform to their stated requirements: + +@cindex JCB002 program +@smallexample + PROGRAM JCB002 +C Version 1: +C Modified 1997-05-21 (Burley) to accommodate compilers that implement +C INT(I1-I2) as INT(I1)-INT(I2) given INTEGER*2 I1,I2. +C +C Version 0: +C Written by James Craig Burley 1997-02-20. +C Contact via Internet email: burley@@gnu.ai.mit.edu +C +C Purpose: +C Determine how compilers handle non-standard IDIM +C on INTEGER*2 operands, which presumably can be +C extrapolated into understanding how the compiler +C generally treats specific intrinsics that are passed +C arguments not of the correct types. +C +C If your compiler implements INTEGER*2 and INTEGER +C as the same type, change all INTEGER*2 below to +C INTEGER*1. +C + INTEGER*2 I0, I4 + INTEGER I1, I2, I3 + INTEGER*2 ISMALL, ILARGE + INTEGER*2 ITOOLG, ITWO + INTEGER*2 ITMP + LOGICAL L2, L3, L4 +C +C Find smallest INTEGER*2 number. +C + ISMALL=0 + 10 I0 = ISMALL-1 + IF ((I0 .GE. ISMALL) .OR. (I0+1 .NE. ISMALL)) GOTO 20 + ISMALL = I0 + GOTO 10 + 20 CONTINUE +C +C Find largest INTEGER*2 number. +C + ILARGE=0 + 30 I0 = ILARGE+1 + IF ((I0 .LE. ILARGE) .OR. (I0-1 .NE. ILARGE)) GOTO 40 + ILARGE = I0 + GOTO 30 + 40 CONTINUE +C +C Multiplying by two adds stress to the situation. +C + ITWO = 2 +C +C Need a number that, added to -2, is too wide to fit in I*2. +C + ITOOLG = ISMALL +C +C Use IDIM the straightforward way. +C + I1 = IDIM (ILARGE, ISMALL) * ITWO + ITOOLG +C +C Calculate result for first interpretation. +C + I2 = (INT (ILARGE) - INT (ISMALL)) * ITWO + ITOOLG +C +C Calculate result for second interpretation. +C + ITMP = ILARGE - ISMALL + I3 = (INT (ITMP)) * ITWO + ITOOLG +C +C Calculate result for third interpretation. +C + I4 = (ILARGE - ISMALL) * ITWO + ITOOLG +C +C Print results. +C + PRINT *, 'ILARGE=', ILARGE + PRINT *, 'ITWO=', ITWO + PRINT *, 'ITOOLG=', ITOOLG + PRINT *, 'ISMALL=', ISMALL + PRINT *, 'I1=', I1 + PRINT *, 'I2=', I2 + PRINT *, 'I3=', I3 + PRINT *, 'I4=', I4 + PRINT * + L2 = (I1 .EQ. I2) + L3 = (I1 .EQ. I3) + L4 = (I1 .EQ. I4) + IF (L2 .AND. .NOT.L3 .AND. .NOT.L4) THEN + PRINT *, 'Interp 1: IDIM(I*2,I*2) => IDIM(INT(I*2),INT(I*2))' + STOP + END IF + IF (L3 .AND. .NOT.L2 .AND. .NOT.L4) THEN + PRINT *, 'Interp 2: IDIM(I*2,I*2) => INT(DIM(I*2,I*2))' + STOP + END IF + IF (L4 .AND. .NOT.L2 .AND. .NOT.L3) THEN + PRINT *, 'Interp 3: IDIM(I*2,I*2) => DIM(I*2,I*2)' + STOP + END IF + PRINT *, 'Results need careful analysis.' + END +@end smallexample + +No future version of the GNU Fortran language +will likely permit specific intrinsic invocations with wrong-typed +arguments (such as @code{IDIM} in the above example), since +it has been determined that disagreements exist among +many production compilers on the interpretation of +such invocations. +These disagreements strongly suggest that Fortran programmers, +and certainly existing Fortran programs, disagree about the +meaning of such invocations. + +The first version of @samp{JCB002} didn't accommodate some compilers' +treatment of @samp{INT(I1-I2)} where @samp{I1} and @samp{I2} are +@code{INTEGER*2}. +In such a case, these compilers apparently convert both +operands to @code{INTEGER*4} and then do an @code{INTEGER*4} subtraction, +instead of doing an @code{INTEGER*2} subtraction on the +original values in @samp{I1} and @samp{I2}. + +However, the results of the careful analyses done on the outputs +of programs compiled by these various compilers show that they +all implement either @samp{Interp 1} or @samp{Interp 2} above. + +Specifically, it is believed that the new version of @samp{JCB002} +above will confirm that: + +@itemize @bullet +@item +Digital Semiconductor (``DEC'') Alpha OSF/1, HP-UX 10.0.1, AIX 3.2.5 +@code{f77} compilers all implement @samp{Interp 1}. + +@item +IRIX 5.3 @code{f77} compiler implements @samp{Interp 2}. + +@item +Solaris 2.5, SunOS 4.1.3, DECstation ULTRIX 4.3, +and IRIX 6.1 @code{f77} compilers all implement @samp{Interp 3}. +@end itemize + +If you get different results than the above for the stated +compilers, or have results for other compilers that might be +worth adding to the above list, please let us know the details +(compiler product, version, machine, results, and so on). + +@node REAL() and AIMAG() of Complex +@subsection @code{REAL()} and @code{AIMAG()} of Complex +@cindex REAL intrinsic +@cindex intrinsics, REAL +@cindex AIMAG intrinsic +@cindex intrinsics, AIMAG + +The GNU Fortran language disallows @code{REAL(@var{expr})} +and @code{AIMAG(@var{expr})}, +where @var{expr} is any @code{COMPLEX} type other than @code{COMPLEX(KIND=1)}, +except when they are used in the following way: + +@example +REAL(REAL(@var{expr})) +REAL(AIMAG(@var{expr})) +@end example + +@noindent +The above forms explicitly specify that the desired effect +is to convert the real or imaginary part of @var{expr}, which might +be some @code{REAL} type other than @code{REAL(KIND=1)}, +to type @code{REAL(KIND=1)}, +and have that serve as the value of the expression. + +The GNU Fortran language offers clearly named intrinsics to extract the +real and imaginary parts of a complex entity without any +conversion: + +@example +REALPART(@var{expr}) +IMAGPART(@var{expr}) +@end example + +To express the above using typical extended FORTRAN 77, +use the following constructs +(when @var{expr} is @code{COMPLEX(KIND=2)}): + +@example +DBLE(@var{expr}) +DIMAG(@var{expr}) +@end example + +The FORTRAN 77 language offers no way +to explicitly specify the real and imaginary parts of a complex expression of +arbitrary type, apparently as a result of requiring support for +only one @code{COMPLEX} type (@code{COMPLEX(KIND=1)}). +The concepts of converting an expression to type @code{REAL(KIND=1)} and +of extracting the real part of a complex expression were +thus ``smooshed'' by FORTRAN 77 into a single intrinsic, since +they happened to have the exact same effect in that language +(due to having only one @code{COMPLEX} type). + +@emph{Note:} When @samp{-ff90} is in effect, +@code{g77} treats @samp{REAL(@var{expr})}, where @var{expr} is of +type @code{COMPLEX}, as @samp{REALPART(@var{expr})}, +whereas with @samp{-fugly-complex -fno-f90} in effect, it is +treated as @samp{REAL(REALPART(@var{expr}))}. + +@xref{Ugly Complex Part Extraction}, for more information. + +@node CMPLX() of DOUBLE PRECISION +@subsection @code{CMPLX()} of @code{DOUBLE PRECISION} +@cindex CMPLX intrinsic +@cindex intrinsics, CMPLX + +In accordance with Fortran 90 and at least some (perhaps all) +other compilers, the GNU Fortran language defines @code{CMPLX()} +as always returning a result that is type @code{COMPLEX(KIND=1)}. + +This means @samp{CMPLX(D1,D2)}, where @samp{D1} and @samp{D2} +are @code{REAL(KIND=2)} (@code{DOUBLE PRECISION}), is treated as: + +@example +CMPLX(SNGL(D1), SNGL(D2)) +@end example + +(It was necessary for Fortran 90 to specify this behavior +for @code{DOUBLE PRECISION} arguments, since that is +the behavior mandated by FORTRAN 77.) + +The GNU Fortran language also provides the @code{DCMPLX()} intrinsic, +which is provided by some FORTRAN 77 compilers to construct +a @code{DOUBLE COMPLEX} entity from of @code{DOUBLE PRECISION} +operands. +However, this solution does not scale well when more @code{COMPLEX} types +(having various precisions and ranges) are offered by Fortran implementations. + +Fortran 90 extends the @code{CMPLX()} intrinsic by adding +an extra argument used to specify the desired kind of complex +result. +However, this solution is somewhat awkward to use, and +@code{g77} currently does not support it. + +The GNU Fortran language provides a simple way to build a complex +value out of two numbers, with the precise type of the value +determined by the types of the two numbers (via the usual +type-promotion mechanism): + +@example +COMPLEX(@var{real}, @var{imag}) +@end example + +When @var{real} and @var{imag} are the same @code{REAL} types, @code{COMPLEX()} +performs no conversion other than to put them together to form a +complex result of the same (complex version of real) type. + +@xref{Complex Intrinsic}, for more information. + +@node MIL-STD 1753 +@subsection MIL-STD 1753 Support +@cindex MIL-STD 1753 + +The GNU Fortran language includes the MIL-STD 1753 intrinsics +@code{BTEST}, @code{IAND}, @code{IBCLR}, @code{IBITS}, +@code{IBSET}, @code{IEOR}, @code{IOR}, @code{ISHFT}, +@code{ISHFTC}, @code{MVBITS}, and @code{NOT}. + +@node f77/f2c Intrinsics +@subsection @code{f77}/@code{f2c} Intrinsics + +The bit-manipulation intrinsics supported by traditional +@code{f77} and by @code{f2c} are available in the GNU Fortran language. +These include @code{AND}, @code{LSHIFT}, @code{OR}, @code{RSHIFT}, +and @code{XOR}. + +Also supported are the intrinsics @code{CDABS}, +@code{CDCOS}, @code{CDEXP}, @code{CDLOG}, @code{CDSIN}, +@code{CDSQRT}, @code{DCMPLX}, @code{DCONJG}, @code{DFLOAT}, +@code{DIMAG}, @code{DREAL}, and @code{IMAG}, +@code{ZABS}, @code{ZCOS}, @code{ZEXP}, @code{ZLOG}, @code{ZSIN}, +and @code{ZSQRT}. + +@node Table of Intrinsic Functions +@subsection Table of Intrinsic Functions +@cindex intrinsics, table of +@cindex table of intrinsics + +(Corresponds to Section 15.10 of ANSI X3.9-1978 FORTRAN 77.) + +The GNU Fortran language adds various functions, subroutines, types, +and arguments to the set of intrinsic functions in ANSI FORTRAN 77. +The complete set of intrinsics supported by the GNU Fortran language +is described below. + +Note that a name is not treated as that of an intrinsic if it is +specified in an @code{EXTERNAL} statement in the same program unit; +if a command-line option is used to disable the groups to which +the intrinsic belongs; or if the intrinsic is not named in an +@code{INTRINSIC} statement and a command-line option is used to +hide the groups to which the intrinsic belongs. + +So, it is recommended that any reference in a program unit to +an intrinsic procedure that is not a standard FORTRAN 77 +intrinsic be accompanied by an appropriate @code{INTRINSIC} +statement in that program unit. +This sort of defensive programming makes it more +likely that an implementation will issue a diagnostic rather +than generate incorrect code for such a reference. + +The terminology used below is based on that of the Fortran 90 +standard, so that the text may be more concise and accurate: + +@itemize @bullet +@item +@code{OPTIONAL} means the argument may be omitted. + +@item +@samp{A-1, A-2, @dots{}, A-n} means more than one argument +(generally named @samp{A}) may be specified. + +@item +@samp{scalar} means the argument must not be an array (must +be a variable or array element, or perhaps a constant if expressions +are permitted). + +@item +@samp{DIMENSION(4)} means the argument must be an array having 4 elements. + +@item +@code{INTENT(IN)} means the argument must be an expression +(such as a constant or a variable that is defined upon invocation +of the intrinsic). + +@item +@code{INTENT(OUT)} means the argument must be definable by the +invocation of the intrinsic (that is, must not be a constant nor +an expression involving operators other than array reference and +substring reference). + +@item +@code{INTENT(INOUT)} means the argument must be defined prior to, +and definable by, invocation of the intrinsic (a combination of +the requirements of @code{INTENT(IN)} and @code{INTENT(OUT)}. + +@item +@xref{Kind Notation} for explanation of @code{KIND}. +@end itemize + +@ifinfo +(Note that the empty lines appearing in the menu below +are not intentional---they result from a bug in the +GNU @code{makeinfo} program@dots{}a program that, if it +did not exist, would leave this document in far worse shape!) +@end ifinfo + +@c The actual documentation for intrinsics comes from +@c intdoc.texi, which in turn is automatically generated +@c from the internal g77 tables in intrin.def _and_ the +@c largely hand-written text in intdoc.h. So, if you want +@c to change or add to existing documentation on intrinsics, +@c you probably want to edit intdoc.h. +@c +@set familyF77 +@set familyGNU +@set familyASC +@set familyMIL +@set familyF90 +@clear familyVXT +@clear familyFVZ +@set familyF2C +@set familyF2U +@clear familyBADU77 +@include intdoc.texi + +@node Scope and Classes of Names +@section Scope and Classes of Symbolic Names +@cindex symbolic names +@cindex scope + +(The following information augments or overrides the information in +Chapter 18 of ANSI X3.9-1978 FORTRAN 77 in specifying the GNU Fortran +language. +Chapter 18 of that document otherwise serves as the basis +for the relevant aspects of GNU Fortran.) + +@menu +* Underscores in Symbol Names:: +@end menu + +@node Underscores in Symbol Names +@subsection Underscores in Symbol Names +@cindex underscores + +Underscores (@samp{_}) are accepted in symbol names after the first +character (which must be a letter). + +@node Other Dialects +@chapter Other Dialects + +GNU Fortran supports a variety of features that are not +considered part of the GNU Fortran language itself, but +are representative of various dialects of Fortran that +@code{g77} supports in whole or in part. + +Any of the features listed below might be disallowed by +@code{g77} unless some command-line option is specified. +Currently, some of the features are accepted using the +default invocation of @code{g77}, but that might change +in the future. + +@emph{Note: This portion of the documentation definitely needs a lot +of work!} + +@menu +* Source Form:: Details of fixed-form and free-form source. +* Trailing Comment:: Use of @samp{/*} to start a comment. +* Debug Line:: Use of @samp{D} in column 1. +* Dollar Signs:: Use of @samp{$} in symbolic names. +* Case Sensitivity:: Uppercase and lowercase in source files. +* VXT Fortran:: @dots{}versus the GNU Fortran language. +* Fortran 90:: @dots{}versus the GNU Fortran language. +* Pedantic Compilation:: Enforcing the standard. +* Distensions:: Misfeatures supported by GNU Fortran. +@end menu + +@node Source Form +@section Source Form +@cindex source file format +@cindex source form +@cindex files, source +@cindex source code +@cindex code, source +@cindex fixed form +@cindex free form + +GNU Fortran accepts programs written in either fixed form or +free form. + +Fixed form +corresponds to ANSI FORTRAN 77 (plus popular extensions, such as +allowing tabs) and Fortran 90's fixed form. + +Free form corresponds to +Fortran 90's free form (though possibly not entirely up-to-date, and +without complaining about some things that for which Fortran 90 requires +diagnostics, such as the spaces in the constant in @samp{R = 3 . 1}). + +The way a Fortran compiler views source files depends entirely on the +implementation choices made for the compiler, since those choices +are explicitly left to the implementation by the published Fortran +standards. +GNU Fortran currently tries to be somewhat like a few popular compilers +(@code{f2c}, Digital (``DEC'') Fortran, and so on), though a cleaner default +definition along with more +flexibility offered by command-line options is likely to be offered +in version 0.6. + +This section describes how @code{g77} interprets source lines. + +@menu +* Carriage Returns:: Carriage returns ignored. +* Tabs:: Tabs converted to spaces. +* Short Lines:: Short lines padded with spaces (fixed-form only). +* Long Lines:: Long lines truncated. +* Ampersands:: Special Continuation Lines. +@end menu + +@node Carriage Returns +@subsection Carriage Returns +@cindex carriage returns + +Carriage returns (@samp{\r}) in source lines are ignored. +This is somewhat different from @code{f2c}, which seems to treat them as +spaces outside character/Hollerith constants, and encodes them as @samp{\r} +inside such constants. + +@node Tabs +@subsection Tabs +@cindex tab characters + +A source line with a @key{TAB} character anywhere in it is treated as +entirely significant---however long it is---instead of ending in +column 72 (for fixed-form source) or 132 (for free-form source). +This also is different from @code{f2c}, which encodes tabs as +@samp{\t} (the ASCII @key{TAB} character) inside character +and Hollerith constants, but nevertheless seems to treat the column +position as if it had been affected by the canonical tab positioning. + +@code{g77} effectively +translates tabs to the appropriate number of spaces (a la the default +for the UNIX @code{expand} command) before doing any other processing, other +than (currently) noting whether a tab was found on a line and using this +information to decide how to interpret the length of the line and continued +constants. + +Note that this default behavior probably will change for version 0.6, +when it will presumably be available via a command-line option. +The default as of version 0.6 is planned to be a ``pure visual'' +model, where tabs are immediately +converted to spaces and otherwise have no effect, so the way a typical +user sees source lines produces a consistent result no matter how the +spacing in those source lines is actually implemented via tabs, spaces, +and trailing tabs/spaces before newline. +Command-line options are likely to be added to specify whether all or +just-tabbed lines are to be extended to 132 or full input-line length, +and perhaps even an option will be added to specify the truncated-line +behavior to which some Digital compilers default (and which affects +the way continued character/Hollerith constants are interpreted). + +@node Short Lines +@subsection Short Lines +@cindex short source lines +@cindex space-padding +@cindex spaces +@cindex source lines, short +@cindex lines, short + +Source lines shorter than the applicable fixed-form length are treated as +if they were padded with spaces to that length. +(None of this is relevant to source files written in free form.) + +This affects only +continued character and Hollerith constants, and is a different +interpretation than provided by some other popular compilers +(although a bit more consistent with the traditional punched-card +basis of Fortran and the way the Fortran standard expressed fixed +source form). + +@code{g77} might someday offer an option to warn about cases where differences +might be seen as a result of this treatment, and perhaps an option to +specify the alternate behavior as well. + +Note that this padding cannot apply to lines that are effectively of +infinite length---such lines are specified using command-line options +like @samp{-ffixed-line-length-none}, for example. + +@node Long Lines +@subsection Long Lines +@cindex long source lines +@cindex truncation +@cindex lines, long +@cindex source lines, long + +Source lines longer than the applicable length are truncated to that +length. +Currently, @code{g77} does not warn if the truncated characters are +not spaces, to accommodate existing code written for systems that +treated truncated text as commentary (especially in columns 73 through 80). + +@xref{Fortran Dialect Options,,Options Controlling Fortran Dialect}, +for information on the @samp{-ffixed-line-length-@var{n}} option, +which can be used to set the line length applicable to fixed-form +source files. + +@node Ampersands +@subsection Ampersand Continuation Line +@cindex ampersand continuation line +@cindex continuation line, ampersand + +A @samp{&} in column 1 of fixed-form source denotes an arbitrary-length +continuation line, imitating the behavior of @code{f2c}. + +@node Trailing Comment +@section Trailing Comment + +@code{g77} supports use of @samp{/*} to start a trailing +comment. +In the GNU Fortran language, @samp{!} is used for this purpose. + +@samp{/*} is not in the GNU Fortran language +because the use of @samp{/*} in a program might +suggest to some readers that a block, not trailing, comment is +started (and thus ended by @samp{*/}, not end of line), +since that is the meaning of @samp{/*} in C. + +Also, such readers might think they can use @samp{//} to start +a trailing comment as an alternative to @samp{/*}, but +@samp{//} already denotes concatenation, and such a ``comment'' +might actually result in a program that compiles without +error (though it would likely behave incorrectly). + +@node Debug Line +@section Debug Line +@cindex debug line + +Use of @samp{D} or @samp{d} as the first character (column 1) of +a source line denotes a debug line. + +In turn, a debug line is treated as either a comment line +or a normal line, depending on whether debug lines are enabled. + +When treated as a comment line, a line beginning with @samp{D} or +@samp{d} is treated as if it the first character was @samp{C} or @samp{c}, respectively. +When treated as a normal line, such a line is treated as if +the first character was @key{SPC} (space). + +(Currently, @code{g77} provides no means for treating debug +lines as normal lines.) + +@node Dollar Signs +@section Dollar Signs in Symbol Names +@cindex dollar sign +@cindex $ + +Dollar signs (@samp{$}) are allowed in symbol names (after the first character) +when the @samp{-fdollar-ok} option is specified. + +@node Case Sensitivity +@section Case Sensitivity +@cindex case sensitivity +@cindex source file format +@cindex code, source +@cindex source code +@cindex uppercase letters +@cindex lowercase letters +@cindex letters, uppercase +@cindex letters, lowercase + +GNU Fortran offers the programmer way too much flexibility in deciding +how source files are to be treated vis-a-vis uppercase and lowercase +characters. +There are 66 useful settings that affect case sensitivity, plus 10 +settings that are nearly useless, with the remaining 116 settings +being either redundant or useless. + +None of these settings have any effect on the contents of comments +(the text after a @samp{c} or @samp{C} in Column 1, for example) +or of character or Hollerith constants. +Note that things like the @samp{E} in the statement +@samp{CALL FOO(3.2E10)} and the @samp{TO} in @samp{ASSIGN 10 TO LAB} +are considered built-in keywords, and so are affected by +these settings. + +Low-level switches are identified in this section as follows: + +@itemize @w{} +@item A +Source Case Conversion: + +@itemize @w{} +@item 0 +Preserve (see Note 1) +@item 1 +Convert to Upper Case +@item 2 +Convert to Lower Case +@end itemize + +@item B +Built-in Keyword Matching: + +@itemize @w{} +@item 0 +Match Any Case (per-character basis) +@item 1 +Match Upper Case Only +@item 2 +Match Lower Case Only +@item 3 +Match InitialCaps Only (see tables for spellings) +@end itemize + +@item C +Built-in Intrinsic Matching: + +@itemize @w{} +@item 0 +Match Any Case (per-character basis) +@item 1 +Match Upper Case Only +@item 2 +Match Lower Case Only +@item 3 +Match InitialCaps Only (see tables for spellings) +@end itemize + +@item D +User-defined Symbol Possibilities (warnings only): + +@itemize @w{} +@item 0 +Allow Any Case (per-character basis) +@item 1 +Allow Upper Case Only +@item 2 +Allow Lower Case Only +@item 3 +Allow InitialCaps Only (see Note 2) +@end itemize +@end itemize + +Note 1: @code{g77} eventually will support @code{NAMELIST} in a manner that is +consistent with these source switches---in the sense that input will be +expected to meet the same requirements as source code in terms +of matching symbol names and keywords (for the exponent letters). + +Currently, however, @code{NAMELIST} is supported by @code{libf2c}, +which uppercases @code{NAMELIST} input and symbol names for matching. +This means not only that @code{NAMELIST} output currently shows symbol +(and keyword) names in uppercase even if lower-case source +conversion (option A2) is selected, but that @code{NAMELIST} cannot be +adequately supported when source case preservation (option A0) +is selected. + +If A0 is selected, a warning message will be +output for each @code{NAMELIST} statement to this effect. +The behavior +of the program is undefined at run time if two or more symbol names +appear in a given @code{NAMELIST} such that the names are identical +when converted to upper case (e.g. @samp{NAMELIST /X/ VAR, Var, var}). +For complete and total elegance, perhaps there should be a warning +when option A2 is selected, since the output of NAMELIST is currently +in uppercase but will someday be lowercase (when a @code{libg77} is written), +but that seems to be overkill for a product in beta test. + +Note 2: Rules for InitialCaps names are: + +@itemize -- +@item +Must be a single uppercase letter, @strong{or} +@item +Must start with an uppercase letter and contain at least one +lowercase letter. +@end itemize + +So @samp{A}, @samp{Ab}, @samp{ABc}, @samp{AbC}, and @samp{Abc} are +valid InitialCaps names, but @samp{AB}, @samp{A2}, and @samp{ABC} are +not. +Note that most, but not all, built-in names meet these +requirements---the exceptions are some of the two-letter format +specifiers, such as @samp{BN} and @samp{BZ}. + +Here are the names of the corresponding command-line options: + +@smallexample +A0: -fsource-case-preserve +A1: -fsource-case-upper +A2: -fsource-case-lower + +B0: -fmatch-case-any +B1: -fmatch-case-upper +B2: -fmatch-case-lower +B3: -fmatch-case-initcap + +C0: -fintrin-case-any +C1: -fintrin-case-upper +C2: -fintrin-case-lower +C3: -fintrin-case-initcap + +D0: -fsymbol-case-any +D1: -fsymbol-case-upper +D2: -fsymbol-case-lower +D3: -fsymbol-case-initcap +@end smallexample + +Useful combinations of the above settings, along with abbreviated +option names that set some of these combinations all at once: + +@smallexample + 1: A0-- B0--- C0--- D0--- -fcase-preserve + 2: A0-- B0--- C0--- D-1-- + 3: A0-- B0--- C0--- D--2- + 4: A0-- B0--- C0--- D---3 + 5: A0-- B0--- C-1-- D0--- + 6: A0-- B0--- C-1-- D-1-- + 7: A0-- B0--- C-1-- D--2- + 8: A0-- B0--- C-1-- D---3 + 9: A0-- B0--- C--2- D0--- +10: A0-- B0--- C--2- D-1-- +11: A0-- B0--- C--2- D--2- +12: A0-- B0--- C--2- D---3 +13: A0-- B0--- C---3 D0--- +14: A0-- B0--- C---3 D-1-- +15: A0-- B0--- C---3 D--2- +16: A0-- B0--- C---3 D---3 +17: A0-- B-1-- C0--- D0--- +18: A0-- B-1-- C0--- D-1-- +19: A0-- B-1-- C0--- D--2- +20: A0-- B-1-- C0--- D---3 +21: A0-- B-1-- C-1-- D0--- +22: A0-- B-1-- C-1-- D-1-- -fcase-strict-upper +23: A0-- B-1-- C-1-- D--2- +24: A0-- B-1-- C-1-- D---3 +25: A0-- B-1-- C--2- D0--- +26: A0-- B-1-- C--2- D-1-- +27: A0-- B-1-- C--2- D--2- +28: A0-- B-1-- C--2- D---3 +29: A0-- B-1-- C---3 D0--- +30: A0-- B-1-- C---3 D-1-- +31: A0-- B-1-- C---3 D--2- +32: A0-- B-1-- C---3 D---3 +33: A0-- B--2- C0--- D0--- +34: A0-- B--2- C0--- D-1-- +35: A0-- B--2- C0--- D--2- +36: A0-- B--2- C0--- D---3 +37: A0-- B--2- C-1-- D0--- +38: A0-- B--2- C-1-- D-1-- +39: A0-- B--2- C-1-- D--2- +40: A0-- B--2- C-1-- D---3 +41: A0-- B--2- C--2- D0--- +42: A0-- B--2- C--2- D-1-- +43: A0-- B--2- C--2- D--2- -fcase-strict-lower +44: A0-- B--2- C--2- D---3 +45: A0-- B--2- C---3 D0--- +46: A0-- B--2- C---3 D-1-- +47: A0-- B--2- C---3 D--2- +48: A0-- B--2- C---3 D---3 +49: A0-- B---3 C0--- D0--- +50: A0-- B---3 C0--- D-1-- +51: A0-- B---3 C0--- D--2- +52: A0-- B---3 C0--- D---3 +53: A0-- B---3 C-1-- D0--- +54: A0-- B---3 C-1-- D-1-- +55: A0-- B---3 C-1-- D--2- +56: A0-- B---3 C-1-- D---3 +57: A0-- B---3 C--2- D0--- +58: A0-- B---3 C--2- D-1-- +59: A0-- B---3 C--2- D--2- +60: A0-- B---3 C--2- D---3 +61: A0-- B---3 C---3 D0--- +62: A0-- B---3 C---3 D-1-- +63: A0-- B---3 C---3 D--2- +64: A0-- B---3 C---3 D---3 -fcase-initcap +65: A-1- B01-- C01-- D01-- -fcase-upper +66: A--2 B0-2- C0-2- D0-2- -fcase-lower +@end smallexample + +Number 22 is the ``strict'' ANSI FORTRAN 77 model wherein all input +(except comments, character constants, and Hollerith strings) must +be entered in uppercase. +Use @samp{-fcase-strict-upper} to specify this +combination. + +Number 43 is like Number 22 except all input must be lowercase. Use +@samp{-fcase-strict-lower} to specify this combination. + +Number 65 is the ``classic'' ANSI FORTRAN 77 model as implemented on many +non-UNIX machines whereby all the source is translated to uppercase. +Use @samp{-fcase-upper} to specify this combination. + +Number 66 is the ``canonical'' UNIX model whereby all the source is +translated to lowercase. +Use @samp{-fcase-lower} to specify this combination. + +There are a few nearly useless combinations: + +@smallexample +67: A-1- B01-- C01-- D--2- +68: A-1- B01-- C01-- D---3 +69: A-1- B01-- C--23 D01-- +70: A-1- B01-- C--23 D--2- +71: A-1- B01-- C--23 D---3 +72: A--2 B01-- C0-2- D-1-- +73: A--2 B01-- C0-2- D---3 +74: A--2 B01-- C-1-3 D0-2- +75: A--2 B01-- C-1-3 D-1-- +76: A--2 B01-- C-1-3 D---3 +@end smallexample + +The above allow some programs to be compiled but with restrictions that +make most useful programs impossible: Numbers 67 and 72 warn about +@emph{any} user-defined symbol names (such as @samp{SUBROUTINE FOO}); +Numbers +68 and 73 warn about any user-defined symbol names longer than one +character that don't have at least one non-alphabetic character after +the first; +Numbers 69 and 74 disallow any references to intrinsics; +and Numbers 70, 71, 75, and 76 are combinations of the restrictions in +67+69, 68+69, 72+74, and 73+74, respectively. + +All redundant combinations are shown in the above tables anyplace +where more than one setting is shown for a low-level switch. +For example, @samp{B0-2-} means either setting 0 or 2 is valid for switch B. +The ``proper'' setting in such a case is the one that copies the setting +of switch A---any other setting might slightly reduce the speed of +the compiler, though possibly to an unmeasurable extent. + +All remaining combinations are useless in that they prevent successful +compilation of non-null source files (source files with something other +than comments). + +@node VXT Fortran +@section VXT Fortran + +@cindex VXT extensions +@cindex extensions, VXT +@code{g77} supports certain constructs that +have different meanings in VXT Fortran than they +do in the GNU Fortran language. + +Generally, this manual uses the invented term VXT Fortran to refer +VAX FORTRAN (circa v4). +That compiler offered many popular features, though not necessarily +those that are specific to the VAX processor architecture, +the VMS operating system, +or Digital Equipment Corporation's Fortran product line. +(VAX and VMS probably are trademarks of Digital Equipment +Corporation.) + +An extension offered by a Digital Fortran product that also is +offered by several other Fortran products for different kinds of +systems is probably going to be considered for inclusion in @code{g77} +someday, and is considered a VXT Fortran feature. + +The @samp{-fvxt} option generally specifies that, where +the meaning of a construct is ambiguous (means one thing +in GNU Fortran and another in VXT Fortran), the VXT Fortran +meaning is to be assumed. + +@menu +* Double Quote Meaning:: @samp{"2000} as octal constant. +* Exclamation Point:: @samp{!} in column 6. +@end menu + +@node Double Quote Meaning +@subsection Meaning of Double Quote +@cindex double quotes +@cindex character constants +@cindex constants, character +@cindex octal constants +@cindex constants, octal + +@code{g77} treats double-quote (@samp{"}) +as beginning an octal constant of @code{INTEGER(KIND=1)} type +when the @code{-fvxt} option is specified. +The form of this octal constant is + +@example +"@var{octal-digits} +@end example + +@noindent +where @var{octal-digits} is a nonempty string of characters in +the set @samp{01234567}. + +For example, the @code{-fvxt} option permits this: + +@example +PRINT *, "20 +END +@end example + +@noindent +The above program would print the value @samp{16}. + +@xref{Integer Type}, for information on the preferred construct +for integer constants specified using GNU Fortran's octal notation. + +(In the GNU Fortran language, the double-quote character (@samp{"}) +delimits a character constant just as does apostrophe (@samp{'}). +There is no way to allow +both constructs in the general case, since statements like +@samp{PRINT *,"2000 !comment?"} would be ambiguous.) + +@node Exclamation Point +@subsection Meaning of Exclamation Point in Column 6 +@cindex exclamation points +@cindex continuation character +@cindex characters, continuation +@cindex comment character +@cindex characters, comment + +@code{g77} treats an exclamation point (@samp{!}) in column 6 of +a fixed-form source file +as a continuation character rather than +as the beginning of a comment +(as it does in any other column) +when the @code{-fvxt} option is specified. + +The following program, when run, prints a message indicating +whether it is interpreted according to GNU Fortran (and Fortran 90) +rules or VXT Fortran rules: + +@smallexample +C234567 (This line begins in column 1.) + I = 0 + !1 + IF (I.EQ.0) PRINT *, ' I am a VXT Fortran program' + IF (I.EQ.1) PRINT *, ' I am a Fortran 90 program' + IF (I.LT.0 .OR. I.GT.1) PRINT *, ' I am a HAL 9000 computer' + END +@end smallexample + +(In the GNU Fortran and Fortran 90 languages, exclamation point is +a valid character and, unlike space (@key{SPC}) or zero (@samp{0}), +marks a line as a continuation line when it appears in column 6.) + +@node Fortran 90 +@section Fortran 90 +@cindex compatibility, Fortran 90 +@cindex Fortran 90 compatibility + +The GNU Fortran language includes a number of features that are +part of Fortran 90, even when the @samp{-ff90} option is not specified. +The features enabled by @samp{-ff90} are intended to be those that, +when @samp{-ff90} is not specified, would have another +meaning to @code{g77}---usually meaning something invalid in the +GNU Fortran language. + +So, the purpose of @samp{-ff90} is not to specify whether @code{g77} is +to gratuitously reject Fortran 90 constructs. +The @samp{-pedantic} option specified with @samp{-fno-f90} is intended +to do that, although its implementation is certainly incomplete at +this point. + +When @samp{-ff90} is specified: + +@itemize @bullet +@item +The type of @samp{REAL(@var{expr})} and @samp{AIMAG(@var{expr})}, +where @var{expr} is @code{COMPLEX} type, +is the same type as the real part of @var{expr}. + +For example, assuming @samp{Z} is type @code{COMPLEX(KIND=2)}, +@samp{REAL(Z)} would return a value of type @code{REAL(KIND=2)}, +not of type @code{REAL(KIND=1)}, since @samp{-ff90} is specified. +@end itemize + +@node Pedantic Compilation +@section Pedantic Compilation +@cindex pedantic compilation +@cindex compilation, pedantic + +The @samp{-fpedantic} command-line option specifies that @code{g77} +is to warn about code that is not standard-conforming. +This is useful for finding +some extensions @code{g77} accepts that other compilers might not accept. +(Note that the @samp{-pedantic} and @samp{-pedantic-errors} options +always imply @samp{-fpedantic}.) + +With @samp{-fno-f90} in force, ANSI FORTRAN 77 is used as the standard +for conforming code. +With @samp{-ff90} in force, Fortran 90 is used. + +The constructs for which @code{g77} issues diagnostics when @samp{-fpedantic} +and @samp{-fno-f90} are in force are: + +@itemize @bullet +@item +Automatic arrays, as in + +@example +SUBROUTINE X(N) +REAL A(N) +@dots{} +@end example + +@noindent +where @samp{A} is not listed in any @code{ENTRY} statement, +and thus is not a dummy argument. + +@item +The commas in @samp{READ (5), I} and @samp{WRITE (10), J}. + +These commas are disallowed by FORTRAN 77, but, while strictly +superfluous, are syntactically elegant, +especially given that commas are required in statements such +as @samp{READ 99, I} and @samp{PRINT *, J}. +Many compilers permit the superfluous commas for this reason. + +@item +@code{DOUBLE COMPLEX}, either explicitly or implicitly. + +An explicit use of this type is via a @code{DOUBLE COMPLEX} or +@code{IMPLICIT DOUBLE COMPLEX} statement, for examples. + +An example of an implicit use is the expression @samp{C*D}, +where @samp{C} is @code{COMPLEX(KIND=1)} +and @samp{D} is @code{DOUBLE PRECISION}. +This expression is prohibited by ANSI FORTRAN 77 +because the rules of promotion would suggest that it +produce a @code{DOUBLE COMPLEX} result---a type not +provided for by that standard. + +@item +Automatic conversion of numeric +expressions to @code{INTEGER(KIND=1)} in contexts such as: + +@itemize -- +@item +Array-reference indexes. +@item +Alternate-return values. +@item +Computed @code{GOTO}. +@item +@code{FORMAT} run-time expressions (not yet supported). +@item +Dimension lists in specification statements. +@item +Numbers for I/O statements (such as @samp{READ (UNIT=3.2), I}) +@item +Sizes of @code{CHARACTER} entities in specification statements. +@item +Kind types in specification entities (a Fortran 90 feature). +@item +Initial, terminal, and incrementation parameters for implied-@code{DO} +constructs in @code{DATA} statements. +@end itemize + +@item +Automatic conversion of @code{LOGICAL} expressions to @code{INTEGER} +in contexts such as arithmetic @code{IF} (where @code{COMPLEX} +expressions are disallowed anyway). + +@item +Zero-size array dimensions, as in: + +@example +INTEGER I(10,20,4:2) +@end example + +@item +Zero-length @code{CHARACTER} entities, as in: + +@example +PRINT *, '' +@end example + +@item +Substring operators applied to character constants and named +constants, as in: + +@example +PRINT *, 'hello'(3:5) +@end example + +@item +Null arguments passed to statement function, as in: + +@example +PRINT *, FOO(,3) +@end example + +@item +Disagreement among program units regarding whether a given @code{COMMON} +area is @code{SAVE}d (for targets where program units in a single source +file are ``glued'' together as they typically are for UNIX development +environments). + +@item +Disagreement among program units regarding the size of a +named @code{COMMON} block. + +@item +Specification statements following first @code{DATA} statement. + +(In the GNU Fortran language, @samp{DATA I/1/} may be followed by @samp{INTEGER J}, +but not @samp{INTEGER I}. +The @samp{-fpedantic} option disallows both of these.) + +@item +Semicolon as statement separator, as in: + +@example +CALL FOO; CALL BAR +@end example +@c +@c @item +@c Comma before list of I/O items in @code{WRITE} +@c @c, @code{ENCODE}, @code{DECODE}, and @code{REWRITE} +@c statements, as with @code{READ} (as explained above). + +@item +Use of @samp{&} in column 1 of fixed-form source (to indicate continuation). + +@item +Use of @code{CHARACTER} constants to initialize numeric entities, and vice +versa. + +@item +Expressions having two arithmetic operators in a row, such +as @samp{X*-Y}. +@end itemize + +If @samp{-fpedantic} is specified along with @samp{-ff90}, the +following constructs result in diagnostics: + +@itemize @bullet +@item +Use of semicolon as a statement separator on a line +that has an @code{INCLUDE} directive. +@end itemize + +@node Distensions +@section Distensions +@cindex distensions +@cindex ugly features +@cindex features, ugly + +The @samp{-fugly-*} command-line options determine whether certain +features supported by VAX FORTRAN and other such compilers, but considered +too ugly to be in code that can be changed to use safer and/or more +portable constructs, are accepted. +These are humorously referred to as ``distensions'', +extensions that just plain look ugly in the harsh light of day. + +@emph{Note:} The @samp{-fugly} option, which currently serves +as shorthand to enable all of the distensions below, is likely to +be removed in a future version of @code{g77}. +That's because it's likely new distensions will be added that +conflict with existing ones in terms of assigning meaning to +a given chunk of code. +(Also, it's pretty clear that users should not use @samp{-fugly} +as shorthand when the next release of @code{g77} might add a +distension to that that causes their existing code, when recompiled, +to behave differently---perhaps even fail to compile or run +correctly.) + +@menu +* Ugly Implicit Argument Conversion:: Disabled via @samp{-fno-ugly-args}. +* Ugly Assumed-Size Arrays:: Enabled via @samp{-fugly-assumed}. +* Ugly Null Arguments:: Enabled via @samp{-fugly-comma}. +* Ugly Complex Part Extraction:: Enabled via @samp{-fugly-complex}. +* Ugly Conversion of Initializers:: Disabled via @samp{-fno-ugly-init}. +* Ugly Integer Conversions:: Enabled via @samp{-fugly-logint}. +* Ugly Assigned Labels:: Enabled via @samp{-fugly-assign}. +@end menu + +@node Ugly Implicit Argument Conversion +@subsection Implicit Argument Conversion +@cindex Hollerith constants +@cindex constants, Hollerith + +The @samp{-fno-ugly-args} option disables +passing typeless and Hollerith constants as actual arguments +in procedure invocations. +For example: + +@example +CALL FOO(4HABCD) +CALL BAR('123'O) +@end example + +@noindent +These constructs can be too easily used to create non-portable +code, but are not considered as ``ugly'' as others. +Further, they are widely used in existing Fortran source code +in ways that often are quite portable. +Therefore, they are enabled by default. + +@node Ugly Assumed-Size Arrays +@subsection Ugly Assumed-Size Arrays +@cindex arrays, assumed-size +@cindex assumed-size arrays +@cindex DIMENSION X(1) + +The @samp{-fugly-assumed} option enables +the treatment of any array with a final dimension specified as @samp{1} +as an assumed-size array, as if @samp{*} had been specified +instead. + +For example, @samp{DIMENSION X(1)} is treated as if it +had read @samp{DIMENSION X(*)} if @samp{X} is listed as +a dummy argument in a preceding @code{SUBROUTINE}, @code{FUNCTION}, +or @code{ENTRY} statement in the same program unit. + +Use an explicit lower bound to avoid this interpretation. +For example, @samp{DIMENSION X(1:1)} is never treated as if +it had read @samp{DIMENSION X(*)} or @samp{DIMENSION X(1:*)}. +Nor is @samp{DIMENSION X(2-1)} affected by this option, +since that kind of expression is unlikely to have been +intended to designate an assumed-size array. + +This option is used to prevent warnings being issued about apparent +out-of-bounds reference such as @samp{X(2) = 99}. + +It also prevents the array from being used in contexts that +disallow assumed-size arrays, such as @samp{PRINT *,X}. +In such cases, a diagnostic is generated and the source file is +not compiled. + +The construct affected by this option is used only in old code +that pre-exists the widespread acceptance of adjustable and assumed-size +arrays in the Fortran community. + +@emph{Note:} This option does not affect how @samp{DIMENSION X(1)} is +treated if @samp{X} is listed as a dummy argument only +@emph{after} the @code{DIMENSION} statement (presumably in +an @code{ENTRY} statement). +For example, @samp{-fugly-assumed} has no effect on the +following program unit: + +@example +SUBROUTINE X +REAL A(1) +RETURN +ENTRY Y(A) +PRINT *, A +END +@end example + +@node Ugly Complex Part Extraction +@subsection Ugly Complex Part Extraction +@cindex complex values +@cindex real part +@cindex imaginary part + +The @samp{-fugly-complex} option enables +use of the @code{REAL()} and @code{AIMAG()} +intrinsics with arguments that are +@code{COMPLEX} types other than @code{COMPLEX(KIND=1)}. + +With @samp{-ff90} in effect, these intrinsics return +the unconverted real and imaginary parts (respectively) +of their argument. + +With @samp{-fno-f90} in effect, these intrinsics convert +the real and imaginary parts to @code{REAL(KIND=1)}, and return +the result of that conversion. + +Due to this ambiguity, the GNU Fortran language defines +these constructs as invalid, except in the specific +case where they are entirely and solely passed as an +argument to an invocation of the @code{REAL()} intrinsic. +For example, + +@example +REAL(REAL(Z)) +@end example + +@noindent +is permitted even when @samp{Z} is @code{COMPLEX(KIND=2)} +and @samp{-fno-ugly-complex} is in effect, because the +meaning is clear. + +@code{g77} enforces this restriction, unless @samp{-fugly-complex} +is specified, in which case the appropriate interpretation is +chosen and no diagnostic is issued. + +@xref{CMPAMBIG}, for information on how to cope with existing +code with unclear expectations of @code{REAL()} and @code{AIMAG()} +with @code{COMPLEX(KIND=2)} arguments. + +@xref{RealPart Intrinsic}, for information on the @code{REALPART()} +intrinsic, used to extract the real part of a complex expression +without conversion. +@xref{ImagPart Intrinsic}, for information on the @code{IMAGPART()} +intrinsic, used to extract the imaginary part of a complex expression +without conversion. + +@node Ugly Null Arguments +@subsection Ugly Null Arguments +@cindex trailing commas +@cindex commas, trailing +@cindex null arguments +@cindex arguments, null + +The @samp{-fugly-comma} option enables +use of a single trailing comma to mean ``pass an extra trailing null +argument'' in a list of actual arguments to a procedure other than a +statement function, and use of an empty list of arguments to +mean ``pass a single null argument''. + +@cindex omitting arguments +@cindex arguments, omitting +(Null arguments often are used in some procedure-calling +schemes to indicate omitted arguments.) + +For example, @samp{CALL FOO(,)} means ``pass +two null arguments'', rather than ``pass one null argument''. +Also, @samp{CALL BAR()} means ``pass one null argument''. + +This construct is considered ``ugly'' because it does not +provide an elegant way to pass a single null argument +that is syntactically distinct from passing no arguments. +That is, this construct changes the meaning of code that +makes no use of the construct. + +So, with @samp{-fugly-comma} in force, @samp{CALL FOO()} +and @samp{I = JFUNC()} pass a single null argument, instead +of passing no arguments as required by the Fortran 77 and +90 standards. + +@emph{Note:} Many systems gracefully allow the case +where a procedure call passes one extra argument that the +called procedure does not expect. + +So, in practice, there might be no difference in +the behavior of a program that does @samp{CALL FOO()} +or @samp{I = JFUNC()} and is compiled with @samp{-fugly-comma} +in force as compared to its behavior when compiled +with the default, @samp{-fno-ugly-comma}, in force, +assuming @samp{FOO} and @samp{JFUNC} do not expect any +arguments to be passed. + +@node Ugly Conversion of Initializers +@subsection Ugly Conversion of Initializers + +The constructs disabled by @samp{-fno-ugly-init} are: + +@itemize @bullet +@cindex Hollerith constants +@cindex constants, Hollerith +@item +Use of Hollerith and typeless constants in contexts where they set +initial (compile-time) values for variables, arrays, and named +constants---that is, @code{DATA} and @code{PARAMETER} statements, plus +type-declaration statements specifying initial values. + +Here are some sample initializations that are disabled by the +@samp{-fno-ugly-init} option: + +@example +PARAMETER (VAL='9A304FFE'X) +REAL*8 STRING/8HOUTPUT00/ +DATA VAR/4HABCD/ +@end example + +@cindex character constants +@cindex constants, character +@item +In the same contexts as above, use of character constants to initialize +numeric items and vice versa (one constant per item). + +Here are more sample initializations that are disabled by the +@samp{-fno-ugly-init} option: + +@example +INTEGER IA +CHARACTER BELL +PARAMETER (IA = 'A') +PARAMETER (BELL = 7) +@end example + +@item +Use of Hollerith and typeless constants on the right-hand side +of assignment statements to numeric types, and in other +contexts (such as passing arguments in invocations of +intrinsic procedures and statement functions) that +are treated as assignments to known types (the dummy +arguments, in these cases). + +Here are sample statements that are disabled by the +@samp{-fno-ugly-init} option: + +@example +IVAR = 4HABCD +PRINT *, IMAX0(2HAB, 2HBA) +@end example +@end itemize + +The above constructs, when used, +can tend to result in non-portable code. +But, they are widely used in existing Fortran code in ways +that often are quite portable. +Therefore, they are enabled by default. + +@node Ugly Integer Conversions +@subsection Ugly Integer Conversions + +The constructs enabled via @samp{-fugly-logint} are: + +@itemize @bullet +@item +Automatic conversion between @code{INTEGER} and @code{LOGICAL} as +dictated by +context (typically implies nonportable dependencies on how a +particular implementation encodes @code{.TRUE.} and @code{.FALSE.}). + +@item +Use of a @code{LOGICAL} variable in @code{ASSIGN} and assigned-@code{GOTO} +statements. +@end itemize + +The above constructs are disabled by default because use +of them tends to lead to non-portable code. +Even existing Fortran code that uses that often turns out +to be non-portable, if not outright buggy. + +Some of this is due to differences among implementations as +far as how @code{.TRUE.} and @code{.FALSE.} are encoded as +@code{INTEGER} values---Fortran code that assumes a particular +coding is likely to use one of the above constructs, and is +also likely to not work correctly on implementations using +different encodings. + +@xref{Equivalence Versus Equality}, for more information. + +@node Ugly Assigned Labels +@subsection Ugly Assigned Labels +@cindex ASSIGN statement +@cindex statements, ASSIGN +@cindex assigned labels +@cindex pointers + +The @samp{-fugly-assign} option forces @code{g77} to use the +same storage for assigned labels as it would for a normal +assignment to the same variable. + +For example, consider the following code fragment: + +@example +I = 3 +ASSIGN 10 TO I +@end example + +@noindent +Normally, for portability and improved diagnostics, @code{g77} +reserves distinct storage for a ``sibling'' of @samp{I}, used +only for @code{ASSIGN} statements to that variable (along with +the corresponding assigned-@code{GOTO} and assigned-@samp{FORMAT}-I/O +statements that reference the variable). + +However, some code (that violates the ANSI FORTRAN 77 standard) +attempts to copy assigned labels among variables involved with +@code{ASSIGN} statements, as in: + +@example +ASSIGN 10 TO I +ISTATE(5) = I +@dots{} +J = ISTATE(ICUR) +GOTO J +@end example + +@noindent +Such code doesn't work under @code{g77} unless @samp{-fugly-assign} +is specified on the command-line, ensuring that the value of @code{I} +referenced in the second line is whatever value @code{g77} uses +to designate statement label @samp{10}, so the value may be +copied into the @samp{ISTATE} array, later retrieved into a +variable of the appropriate type (@samp{J}), and used as the target of +an assigned-@code{GOTO} statement. + +@emph{Note:} To avoid subtle program bugs, +when @samp{-fugly-assign} is specified, +@code{g77} requires the type of variables +specified in assigned-label contexts +@emph{must} be the same type returned by @code{%LOC()}. +On many systems, this type is effectively the same +as @code{INTEGER(KIND=1)}, while, on others, it is +effectively the same as @code{INTEGER(KIND=2)}. + +Do @emph{not} depend on @code{g77} actually writing valid pointers +to these variables, however. +While @code{g77} currently chooses that implementation, it might +be changed in the future. + +@xref{Assigned Statement Labels,,Assigned Statement Labels (ASSIGN and GOTO)}, +for implementation details on assigned-statement labels. + +@node Compiler +@chapter The GNU Fortran Compiler + +The GNU Fortran compiler, @code{g77}, supports programs written +in the GNU Fortran language and in some other dialects of Fortran. + +Some aspects of how @code{g77} works are universal regardless +of dialect, and yet are not properly part of the GNU Fortran +language itself. +These are described below. + +@emph{Note: This portion of the documentation definitely needs a lot +of work!} + +@menu +* Compiler Limits:: +* Compiler Types:: +* Compiler Constants:: +* Compiler Intrinsics:: +@end menu + +@node Compiler Limits +@section Compiler Limits +@cindex limits, compiler +@cindex compiler limits + +@code{g77}, as with GNU tools in general, imposes few arbitrary restrictions +on lengths of identifiers, number of continuation lines, number of external +symbols in a program, and so on. + +@cindex options, -Nl +@cindex -Nl option +@cindex options, -Nx +@cindex -Nx option +For example, some other Fortran compiler have an option +(such as @samp{-Nl@var{x}}) to increase the limit on the +number of continuation lines. +Also, some Fortran compilation systems have an option +(such as @samp{-Nx@var{x}}) to increase the limit on the +number of external symbols. + +@code{g77}, @code{gcc}, and GNU @code{ld} (the GNU linker) have +no equivalent options, since they do not impose arbitrary +limits in these areas. + +@cindex rank, maximum +@cindex maximum rank +@cindex number of dimensions, maximum +@cindex maximum number of dimensions +@code{g77} does currently limit the number of dimensions in an array +to the same degree as do the Fortran standards---seven (7). +This restriction might well be lifted in a future version. + +@node Compiler Types +@section Compiler Types +@cindex types, of data +@cindex data types + +Fortran implementations have a fair amount of freedom given them by the +standard as far as how much storage space is used and how much precision +and range is offered by the various types such as @code{LOGICAL(KIND=1)}, +@code{INTEGER(KIND=1)}, @code{REAL(KIND=1)}, @code{REAL(KIND=2)}, +@code{COMPLEX(KIND=1)}, and @code{CHARACTER}. +Further, many compilers offer so-called @samp{*@var{n}} notation, but +the interpretation of @var{n} varies across compilers and target architectures. + +The standard requires that @code{LOGICAL(KIND=1)}, @code{INTEGER(KIND=1)}, +and @code{REAL(KIND=1)} +occupy the same amount of storage space, and that @code{COMPLEX(KIND=1)} +and @code{REAL(KIND=2)} take twice as much storage space as @code{REAL(KIND=1)}. +Further, it requires that @code{COMPLEX(KIND=1)} +entities be ordered such that when a @code{COMPLEX(KIND=1)} variable is +storage-associated (such as via @code{EQUIVALENCE}) +with a two-element @code{REAL(KIND=1)} array named @samp{R}, @samp{R(1)} +corresponds to the real element and @samp{R(2)} to the imaginary +element of the @code{COMPLEX(KIND=1)} variable. + +(Few requirements as to precision or ranges of any of these are +placed on the implementation, nor is the relationship of storage sizes of +these types to the @code{CHARACTER} type specified, by the standard.) + +@code{g77} follows the above requirements, warning when compiling +a program requires placement of items in memory that contradict the +requirements of the target architecture. +(For example, a program can require placement of a @code{REAL(KIND=2)} +on a boundary that is not an even multiple of its size, but still an +even multiple of the size of a @code{REAL(KIND=1)} variable. +On some target architectures, using the canonical +mapping of Fortran types to underlying architectural types, such +placement is prohibited by the machine definition or +the Application Binary Interface (ABI) in force for +the configuration defined for building @code{gcc} and @code{g77}. +@code{g77} warns about such +situations when it encounters them.) + +@code{g77} follows consistent rules for configuring the mapping between Fortran +types, including the @samp{*@var{n}} notation, and the underlying architectural +types as accessed by a similarly-configured applicable version of the +@code{gcc} compiler. +These rules offer a widely portable, consistent Fortran/C +environment, although they might well conflict with the expectations of +users of Fortran compilers designed and written for particular +architectures. + +These rules are based on the configuration that is in force for the +version of @code{gcc} built in the same release as @code{g77} (and +which was therefore used to build both the @code{g77} compiler +components and the @code{libf2c} run-time library): + +@table @code +@cindex REAL(KIND=1) type +@cindex types, REAL(KIND=1) +@item REAL(KIND=1) +Same as @code{float} type. + +@cindex REAL(KIND=2) type +@cindex types, REAL(KIND=2) +@item REAL(KIND=2) +Same as whatever floating-point type that is twice the size +of a @code{float}---usually, this is a @code{double}. + +@cindex INTEGER(KIND=1) type +@cindex types, INTEGER(KIND=1) +@item INTEGER(KIND=1) +Same as an integral type that is occupies the same amount +of memory storage as @code{float}---usually, this is either +an @code{int} or a @code{long int}. + +@cindex LOGICAL(KIND=1) type +@cindex types, LOGICAL(KIND=1) +@item LOGICAL(KIND=1) +Same @code{gcc} type as @code{INTEGER(KIND=1)}. + +@cindex INTEGER(KIND=2) type +@cindex types, INTEGER(KIND=2) +@item INTEGER(KIND=2) +Twice the size, and usually nearly twice the range, +as @code{INTEGER(KIND=1)}---usually, this is either +a @code{long int} or a @code{long long int}. + +@cindex LOGICAL(KIND=2) type +@cindex types, LOGICAL(KIND=2) +@item LOGICAL(KIND=2) +Same @code{gcc} type as @code{INTEGER(KIND=2)}. + +@cindex INTEGER(KIND=3) type +@cindex types, INTEGER(KIND=3) +@item INTEGER(KIND=3) +Same @code{gcc} type as signed @code{char}. + +@cindex LOGICAL(KIND=3) type +@cindex types, LOGICAL(KIND=3) +@item LOGICAL(KIND=3) +Same @code{gcc} type as @code{INTEGER(KIND=3)}. + +@cindex INTEGER(KIND=6) type +@cindex types, INTEGER(KIND=6) +@item INTEGER(KIND=6) +Twice the size, and usually nearly twice the range, +as @code{INTEGER(KIND=3)}---usually, this is +a @code{short}. + +@cindex LOGICAL(KIND=6) type +@cindex types, LOGICAL(KIND=6) +@item LOGICAL(KIND=6) +Same @code{gcc} type as @code{INTEGER(KIND=6)}. + +@cindex COMPLEX(KIND=1) type +@cindex types, COMPLEX(KIND=1) +@item COMPLEX(KIND=1) +Two @code{REAL(KIND=1)} scalars (one for the real part followed by +one for the imaginary part). + +@cindex COMPLEX(KIND=2) type +@cindex types, COMPLEX(KIND=2) +@item COMPLEX(KIND=2) +Two @code{REAL(KIND=2)} scalars. + +@cindex *@var{n} notation +@item @var{numeric-type}*@var{n} +(Where @var{numeric-type} is any type other than @code{CHARACTER}.)@ +Same as whatever @code{gcc} type occupies @var{n} times the storage +space of a @code{gcc} @code{char} item. + +@cindex DOUBLE PRECISION type +@cindex types, DOUBLE PRECISION +@item DOUBLE PRECISION +Same as @code{REAL(KIND=2)}. + +@cindex DOUBLE COMPLEX type +@cindex types, DOUBLE COMPLEX +@item DOUBLE COMPLEX +Same as @code{COMPLEX(KIND=2)}. +@end table + +Note that the above are proposed correspondences and might change +in future versions of @code{g77}---avoid writing code depending +on them. + +Other types supported by @code{g77} +are derived from gcc types such as @code{char}, @code{short}, +@code{int}, @code{long int}, @code{long long int}, @code{long double}, +and so on. +That is, whatever types @code{gcc} already supports, @code{g77} supports +now or probably will support in a future version. +The rules for the @samp{@var{numeric-type}*@var{n}} notation +apply to these types, +and new values for @samp{@var{numeric-type}(KIND=@var{n})} will be +assigned in a way that encourages clarity, consistency, and portability. + +@node Compiler Constants +@section Compiler Constants +@cindex constants +@cindex types, constants + +@code{g77} strictly assigns types to @emph{all} constants not +documented as ``typeless'' (typeless constants including @samp{'1'Z}, +for example). +Many other Fortran compilers attempt to assign types to typed constants +based on their context. +This results in hard-to-find bugs, nonportable +code, and is not in the spirit (though it strictly follows the letter) +of the 77 and 90 standards. + +@code{g77} might offer, in a future release, explicit constructs by +which a wider variety of typeless constants may be specified, and/or +user-requested warnings indicating places where @code{g77} might differ +from how other compilers assign types to constants. + +@xref{Context-Sensitive Constants}, for more information on this issue. + +@node Compiler Intrinsics +@section Compiler Intrinsics + +@code{g77} offers an ever-widening set of intrinsics. +Currently these all are procedures (functions and subroutines). + +Some of these intrinsics are unimplemented, but their names reserved +to reduce future problems with existing code as they are implemented. +Others are implemented as part of the GNU Fortran language, while +yet others are provided for compatibility with other dialects of +Fortran but are not part of the GNU Fortran language. + +To manage these distinctions, @code{g77} provides intrinsic @emph{groups}, +a facility that is simply an extension of the intrinsic groups provided +by the GNU Fortran language. + +@menu +* Intrinsic Groups:: How intrinsics are grouped for easy management. +* Other Intrinsics:: Intrinsics other than those in the GNU + Fortran language. +@end menu + +@node Intrinsic Groups +@subsection Intrinsic Groups +@cindex groups of intrinsics +@cindex intrinsics, groups + +A given specific intrinsic belongs in one or more groups. +Each group is deleted, disabled, hidden, or enabled +by default or a command-line option. +The meaning of each term follows. + +@table @b +@cindex deleted intrinsics +@cindex intrinsics, deleted +@item Deleted +No intrinsics are recognized as belonging to that group. + +@cindex disabled intrinsics +@cindex intrinsics, disabled +@item Disabled +Intrinsics are recognized as belonging to the group, but +references to them (other than via the @code{INTRINSIC} statement) +are disallowed through that group. + +@cindex hidden intrinsics +@cindex intrinsics, hidden +@item Hidden +Intrinsics in that group are recognized and enabled (if implemented) +@emph{only} if the first mention of the actual name of an intrinsic +in a program unit is in an @code{INTRINSIC} statement. + +@cindex enabled intrinsics +@cindex intrinsics, enabled +@item Enabled +Intrinsics in that group are recognized and enabled (if implemented). +@end table + +The distinction between deleting and disabling a group is illustrated +by the following example. +Assume intrinsic @samp{FOO} belongs only to group @samp{FGR}. +If group @samp{FGR} is deleted, the following program unit will +successfully compile, because @samp{FOO()} will be seen as a +reference to an external function named @samp{FOO}: + +@example +PRINT *, FOO() +END +@end example + +@noindent +If group @samp{FGR} is disabled, compiling the above program will produce +diagnostics, either because the @samp{FOO} intrinsic is improperly invoked +or, if properly invoked, it is not enabled. +To change the above program so it references an external function @samp{FOO} +instead of the disabled @samp{FOO} intrinsic, +add the following line to the top: + +@example +EXTERNAL FOO +@end example + +@noindent +So, deleting a group tells @code{g77} to pretend as though the intrinsics in +that group do not exist at all, whereas disabling it tells @code{g77} to +recognize them as (disabled) intrinsics in intrinsic-like contexts. + +Hiding a group is like enabling it, but the intrinsic must be first +named in an @code{INTRINSIC} statement to be considered a reference to the +intrinsic rather than to an external procedure. +This might be the ``safest'' way to treat a new group of intrinsics +when compiling old +code, because it allows the old code to be generally written as if +those new intrinsics never existed, but to be changed to use them +by inserting @code{INTRINSIC} statements in the appropriate places. +However, it should be the goal of development to use @code{EXTERNAL} +for all names of external procedures that might be intrinsic names. + +If an intrinsic is in more than one group, it is enabled if any of its +containing groups are enabled; if not so enabled, it is hidden if +any of its containing groups are hidden; if not so hidden, it is disabled +if any of its containing groups are disabled; if not so disabled, it is +deleted. +This extra complication is necessary because some intrinsics, +such as @code{IBITS}, belong to more than one group, and hence should be +enabled if any of the groups to which they belong are enabled, and so +on. + +The groups are: + +@cindex intrinsics, groups of +@cindex groups of intrinsics +@table @code +@item badu77 +UNIX intrinsics having inappropriate forms (usually functions that +have intended side effects). + +@item gnu +Intrinsics the GNU Fortran language supports that are extensions to +the Fortran standards (77 and 90). + +@item f2c +Intrinsics supported by AT&T's @code{f2c} converter and/or @code{libf2c}. + +@item f90 +Fortran 90 intrinsics. + +@item mil +MIL-STD 1753 intrinsics (@code{MVBITS}, @code{IAND}, @code{BTEST}, and so on). + +@item unix +UNIX intrinsics (@code{IARGC}, @code{EXIT}, @code{ERF}, and so on). + +@item vxt +VAX/VMS FORTRAN (current as of v4) intrinsics. +@end table + +@node Other Intrinsics +@subsection Other Intrinsics +@cindex intrinsics, others +@cindex other intrinsics + +@code{g77} supports intrinsics other than those in the GNU Fortran +language proper. +This set of intrinsics is described below. + +@ifinfo +(Note that the empty lines appearing in the menu below +are not intentional---they result from a bug in the +@code{makeinfo} program.) +@end ifinfo + +@c The actual documentation for intrinsics comes from +@c intdoc.texi, which in turn is automatically generated +@c from the internal g77 tables in intrin.def _and_ the +@c largely hand-written text in intdoc.h. So, if you want +@c to change or add to existing documentation on intrinsics, +@c you probably want to edit intdoc.h. +@c +@clear familyF77 +@clear familyGNU +@clear familyASC +@clear familyMIL +@clear familyF90 +@set familyVXT +@set familyFVZ +@clear familyF2C +@clear familyF2U +@set familyBADU77 +@include intdoc.texi + +@node Other Compilers +@chapter Other Compilers + +An individual Fortran source file can be compiled to +an object (@file{*.o}) file instead of to the final +program executable. +This allows several portions of a program to be compiled +at different times and linked together whenever a new +version of the program is needed. +However, it introduces the issue of @dfn{object compatibility} +across the various object files (and libraries, or @file{*.a} +files) that are linked together to produce any particular +executable file. + +Object compatibility is an issue when combining, in one +program, Fortran code compiled by more than one compiler +(or more than one configuration of a compiler). +If the compilers +disagree on how to transform the names of procedures, there +will normally be errors when linking such programs. +Worse, if the compilers agree on naming, but disagree on issues +like how to pass parameters, return arguments, and lay out +@code{COMMON} areas, the earliest detected errors might be the +incorrect results produced by the program (and that assumes +these errors are detected, which is not always the case). + +Normally, @code{g77} generates code that is +object-compatible with code generated by a version of +@code{f2c} configured (with, for example, @file{f2c.h} definitions) +to be generally compatible with @code{g77} as built by @code{gcc}. +(Normally, @code{f2c} will, by default, conform to the appropriate +configuration, but it is possible that older or perhaps even newer +versions of @code{f2c}, or versions having certain configuration changes +to @code{f2c} internals, will produce object files that are +incompatible with @code{g77}.) + +For example, a Fortran string subroutine +argument will become two arguments on the C side: a @code{char *} +and an @code{int} length. + +Much of this compatibility results from the fact that +@code{g77} uses the same run-time library, @code{libf2c}, used by +@code{f2c}. + +Other compilers might or might not generate code that +is object-compatible with @code{libf2c} and current @code{g77}, +and some might offer such compatibility only when explicitly +selected via a command-line option to the compiler. + +@emph{Note: This portion of the documentation definitely needs a lot +of work!} + +@menu +* Dropping f2c Compatibility:: When speed is more important. +* Compilers Other Than f2c:: Interoperation with code from other compilers. +@end menu + +@node Dropping f2c Compatibility +@section Dropping @code{f2c} Compatibility + +Specifying @samp{-fno-f2c} allows @code{g77} to generate, in +some cases, faster code, by not needing to allow to the possibility +of linking with code compiled by @code{f2c}. + +For example, this affects how @code{REAL(KIND=1)}, +@code{COMPLEX(KIND=1)}, and @code{COMPLEX(KIND=2)} functions are called. +With @samp{-fno-f2c}, they are +compiled as returning the appropriate @code{gcc} type +(@code{float}, @code{__complex__ float}, @code{__complex__ double}, +in many configurations). + +With @samp{-ff2c} in force, they +are compiled differently (with perhaps slower run-time performance) +to accommodate the restrictions inherent in @code{f2c}'s use of K&R +C as an intermediate language---@code{REAL(KIND=1)} functions +return C's @code{double} type, while @code{COMPLEX} functions return +@code{void} and use an extra argument pointing to a place for the functions to +return their values. + +It is possible that, in some cases, leaving @samp{-ff2c} in force +might produce faster code than using @samp{-fno-f2c}. +Feel free to experiment, but remember to experiment with changing the way +@emph{entire programs and their Fortran libraries are compiled} at +a time, since this sort of experimentation affects the interface +of code generated for a Fortran source file---that is, it affects +object compatibility. + +Note that @code{f2c} compatibility is a fairly static target to achieve, +though not necessarily perfectly so, since, like @code{g77}, it is +still being improved. +However, specifying @samp{-fno-f2c} causes @code{g77} +to generate code that will probably be incompatible with code +generated by future versions of @code{g77} when the same option +is in force. +You should make sure you are always able to recompile complete +programs from source code when upgrading to new versions of @code{g77} +or @code{f2c}, especially when using options such as @samp{-fno-f2c}. + +Therefore, if you are using @code{g77} to compile libraries and other +object files for possible future use and you don't want to require +recompilation for future use with subsequent versions of @code{g77}, +you might want to stick with @code{f2c} compatibility for now, and +carefully watch for any announcements about changes to the +@code{f2c}/@code{libf2c} interface that might affect existing programs +(thus requiring recompilation). + +It is probable that a future version of @code{g77} will not, +by default, generate object files compatible with @code{f2c}, +and that version probably would no longer use @code{libf2c}. +If you expect to depend on this compatibility in the +long term, use the options @samp{-ff2c -ff2c-library} when compiling +all of the applicable code. +This should cause future versions of @code{g77} either to produce +compatible code (at the expense of the availability of some features and +performance), or at the very least, to produce diagnostics. + +@node Compilers Other Than f2c +@section Compilers Other Than @code{f2c} + +On systems with Fortran compilers other than @code{f2c} and @code{g77}, +code compiled by @code{g77} is not expected to work +well with code compiled by the native compiler. +(This is true for @code{f2c}-compiled objects as well.)@ +Libraries compiled with the native compiler probably will have +to be recompiled with @code{g77} to be used with @code{g77}-compiled code. + +Reasons for such incompatibilities include: + +@itemize @bullet +@item +There might be differences in the way names of Fortran procedures +are translated for use in the system's object-file format. +For example, the statement @samp{CALL FOO} might be compiled +by @code{g77} to call a procedure the linker @code{ld} sees +given the name @samp{_foo_}, while the apparently corresponding +statement @samp{SUBROUTINE FOO} might be compiled by the +native compiler to define the linker-visible name @samp{_foo}, +or @samp{_FOO_}, and so on. + +@item +There might be subtle type mismatches which cause subroutine arguments +and function return values to get corrupted. + +This is why simply getting @code{g77} to +transform procedure names the same way a native +compiler does is not usually a good idea---unless +some effort has been made to ensure that, aside +from the way the two compilers transform procedure +names, everything else about the way they generate +code for procedure interfaces is identical. + +@item +Native compilers +use libraries of private I/O routines which will not be available +at link time unless you have the native compiler---and you would +have to explicitly ask for them. + +For example, on the Sun you +would have to add @samp{-L/usr/lang/SCx.x -lF77 -lV77} to the link +command. +@end itemize + +@node Other Languages +@chapter Other Languages + +@emph{Note: This portion of the documentation definitely needs a lot +of work!} + +@menu +* Interoperating with C and C++:: +@end menu + +@node Interoperating with C and C++ +@section Tools and advice for interoperating with C and C++ + +@cindex C, linking with +@cindex C++, linking with +@cindex linking with C +The following discussion assumes that you are running @code{g77} in @code{f2c} +compatibility mode, i.e.@ not using @samp{-fno-f2c}. +It provides some +advice about quick and simple techniques for linking Fortran and C (or +C++), the most common requirement. +For the full story consult the +description of code generation. +@xref{Debugging and Interfacing}. + +When linking Fortran and C, it's usually best to use @code{g77} to do +the linking so that the correct libraries are included (including the +maths one). +If you're linking with C++ you will want to add +@samp{-lstdc++}, @samp{-lg++} or whatever. +If you need to use another +driver program (or @code{ld} directly), +you can find out what linkage +options @code{g77} passes by running @samp{g77 -v}. + +@menu +* C Interfacing Tools:: +* C Access to Type Information:: +* f2c Skeletons and Prototypes:: +* C++ Considerations:: +* Startup Code:: +@end menu + +@node C Interfacing Tools +@subsection C Interfacing Tools +@pindex f2c +@cindex cfortran.h +@cindex Netlib +Even if you don't actually use it as a compiler, @samp{f2c} from +@url{ftp://ftp.netlib.org/f2c/src}, can be a useful tool when you're +interfacing (linking) Fortran and C@. +@xref{f2c Skeletons and Prototypes,,Generating Skeletons and Prototypes with @code{f2c}}. + +To use @code{f2c} for this purpose you only need retrieve and +build the @file{src} directory from the distribution, consult the +@file{README} instructions there for machine-specifics, and install the +@code{f2c} program on your path. + +Something else that might be useful is @samp{cfortran.h} from +@url{ftp://zebra/desy.de/cfortran}. +This is a fairly general tool which +can be used to generate interfaces for calling in both directions +between Fortran and C@. +It can be used in @code{f2c} mode with +@code{g77}---consult its documentation for details. + +@node C Access to Type Information +@subsection Accessing Type Information in C + +@cindex types, Fortran/C +Generally, C code written to link with +@code{g77} code---calling and/or being +called from Fortran---should @samp{#include } to define the C +versions of the Fortran types. +Don't assume Fortran @code{INTEGER} types +correspond to C @samp{int}s, for instance; instead, declare them as +@code{integer}, a type defined by @file{f2c.h}. +@file{f2c.h} is installed where @code{gcc} will find it by +default, assuming you use a copy of @code{gcc} compatible with +@code{g77}, probably built at the same time as @code{g77}. + +@node f2c Skeletons and Prototypes +@subsection Generating Skeletons and Prototypes with @code{f2c} + +@pindex f2c +@cindex -fno-second-underscore +A simple and foolproof way to write @code{g77}-callable C routines---e.g.@ to +interface with an existing library---is to write a file (named, for +example, @file{fred.f}) of dummy Fortran +skeletons comprising just the declaration of the routine(s) and dummy +arguments plus @samp{END} statements. +Then run @code{f2c} on file @file{fred.f} to produce @file{fred.c} +into which you can edit +useful code, confident the calling sequence is correct, at least. +(There are some errors otherwise commonly made in generating C +interfaces with f2c conventions, such as not using @code{doublereal} as +the return type of a @code{REAL} @code{FUNCTION}.) + +@pindex ftnchek +@code{f2c} also can help with calling Fortran from C, using its +@samp{-P} option to generate C prototypes appropriate for calling the +Fortran.@footnote{The files generated like this can also be used for +inter-unit consistency checking of dummy and actual arguments, although +the @samp{ftnchek} tool from @url{ftp://ftp.netlib.org/fortran} is +probably better for this purpose.} +If the Fortran code containing any +routines to be called from C is in file @file{joe.f}, use the command +@kbd{f2c -P joe.f} to generate the file @file{joe.P} containing +prototype information. +@code{#include} this in the C which has to call +the Fortran routines to make sure you get it right. + +@xref{Arrays,,Arrays (DIMENSION}, for information on the differences +between the way Fortran (including compilers like @code{g77}) and +C handle arrays. + +@node C++ Considerations +@subsection C++ Considerations + +@cindex C++ +@code{f2c} can be used to generate suitable code for compilation with a +C++ system using the @samp{-C++} option. +The important thing about linking @code{g77}-compiled +code with C++ is that the prototypes for the @code{g77} +routines must specify C linkage to avoid name mangling. +So, use an @samp{extern "C"} declaration. +@code{f2c}'s @samp{-C++} option will take care +of this when generating skeletons or prototype files as above, and also +avoid clashes with C++ reserved words in addition to those in C@. + +@node Startup Code +@subsection Startup Code + +@cindex startup code +@cindex runtime initialization +@cindex initialization, runtime +Unlike with some runtime systems, it shouldn't be necessary (unless there are +bugs) to use a Fortran main program to ensure the +runtime---specifically the i/o system---is initialized. +However, to use +the @code{g77} intrinsics @code{GETARG()} and @code{IARGC()} the +@code{main()} routine from the @file{libf2c} library must be used, either +explicitly or implicitly by using a Fortran main program. +This +@code{main()} program calls @code{MAIN__()} (where the names are C-type +@code{extern} names, i.e.@ not mangled). +You need to provide this +nullary procedure as the entry point for your C code if using +@file{libf2c}'s @code{main}. +In some cases it might be necessary to +provide a dummy version of this to avoid linkers complaining about +failure to resolve @code{MAIN__()} if linking against @file{libf2c} and +not using @code{main()} from it. + +@include install.texi + +@node Debugging and Interfacing +@chapter Debugging and Interfacing +@cindex debugging +@cindex interfacing +@cindex calling C routines +@cindex C routines calling Fortran +@cindex f2c compatibility + +GNU Fortran currently generates code that is object-compatible with +the @code{f2c} converter. +Also, it avoids limitations in the current GBE, such as the +inability to generate a procedure with +multiple entry points, by generating code that is structured +differently (in terms of procedure names, scopes, arguments, and +so on) than might be expected. + +As a result, writing code in other languages that calls on, is +called by, or shares in-memory data with @code{g77}-compiled code generally +requires some understanding of the way @code{g77} compiles code for +various constructs. + +Similarly, using a debugger to debug @code{g77}-compiled +code, even if that debugger supports native Fortran debugging, generally +requires this sort of information. + +This section describes some of the basic information on how +@code{g77} compiles code for constructs involving interfaces to other +languages and to debuggers. + +@emph{Caution:} Much or all of this information pertains to only the current +release of @code{g77}, sometimes even to using certain compiler options +with @code{g77} (such as @samp{-fno-f2c}). +Do not write code that depends on this +information without clearly marking said code as nonportable and +subject to review for every new release of @code{g77}. +This information +is provided primarily to make debugging of code generated by this +particular release of @code{g77} easier for the user, and partly to make +writing (generally nonportable) interface code easier. +Both of these +activities require tracking changes in new version of @code{g77} as they +are installed, because new versions can change the behaviors +described in this section. + +@menu +* Main Program Unit:: How @code{g77} compiles a main program unit. +* Procedures:: How @code{g77} constructs parameter lists + for procedures. +* Functions:: Functions returning floating-point or character data. +* Names:: Naming of user-defined variables, procedures, etc. +* Common Blocks:: Accessing common variables while debugging. +* Local Equivalence Areas:: Accessing @code{EQUIVALENCE} while debugging. +* Complex Variables:: How @code{g77} performs complex arithmetic. +* Arrays:: Dealing with (possibly multi-dimensional) arrays. +* Adjustable Arrays:: Special consideration for adjustable arrays. +* Alternate Entry Points:: How @code{g77} implements alternate @code{ENTRY}. +* Alternate Returns:: How @code{g77} handles alternate returns. +* Assigned Statement Labels:: How @code{g77} handles @code{ASSIGN}. +* Run-time Library Errors:: Meanings of some @code{IOSTAT=} values. +@end menu + +@node Main Program Unit +@section Main Program Unit (PROGRAM) +@cindex PROGRAM statement +@cindex statements, PROGRAM + +When @code{g77} compiles a main program unit, it gives it the public +procedure name @samp{MAIN__}. +The @code{libf2c} library has the actual @code{main()} procedure +as is typical of C-based environments, and +it is this procedure that performs some initial start-up +activity and then calls @samp{MAIN__}. + +Generally, @code{g77} and @code{libf2c} are designed so that you need not +include a main program unit written in Fortran in your program---it +can be written in C or some other language. +Especially for I/O handling, this is the case, although @code{g77} version 0.5.16 +includes a bug fix for @code{libf2c} that solved a problem with using the +@code{OPEN} statement as the first Fortran I/O activity in a program +without a Fortran main program unit. + +However, if you don't intend to use @code{g77} (or @code{f2c}) to compile +your main program unit---that is, if you intend to compile a @code{main()} +procedure using some other language---you should carefully +examine the code for @code{main()} in @code{libf2c}, found in the source +file @file{gcc/f/runtime/libF77/main.c}, to see what kinds of things +might need to be done by your @code{main()} in order to provide the +Fortran environment your Fortran code is expecting. + +@cindex IARGC() intrinsic +@cindex intrinsics, IARGC() +@cindex GETARG() intrinsic +@cindex intrinsics, GETARG() +For example, @code{libf2c}'s @code{main()} sets up the information used by +the @code{IARGC} and @code{GETARG} intrinsics. +Bypassing @code{libf2c}'s @code{main()} +without providing a substitute for this activity would mean +that invoking @code{IARGC} and @code{GETARG} would produce undefined +results. + +@cindex debugging +@cindex main program unit, debugging +@cindex main() +@cindex MAIN__() +@cindex .gdbinit +When debugging, one implication of the fact that @code{main()}, which +is the place where the debugged program ``starts'' from the +debugger's point of view, is in @code{libf2c} is that you won't be +starting your Fortran program at a point you recognize as your +Fortran code. + +The standard way to get around this problem is to set a break +point (a one-time, or temporary, break point will do) at +the entrance to @samp{MAIN__}, and then run the program. +A convenient way to do so is to add the @code{gdb} command + +@example +tbreak MAIN__ +@end example + +@noindent +to the file @file{.gdbinit} in the directory in which you're debugging +(using @code{gdb}). + +After doing this, the debugger will see the current execution +point of the program as at the beginning of the main program +unit of your program. + +Of course, if you really want to set a break point at some +other place in your program and just start the program +running, without first breaking at @samp{MAIN__}, +that should work fine. + +@node Procedures +@section Procedures (SUBROUTINE and FUNCTION) +@cindex procedures +@cindex SUBROUTINE statement +@cindex statements, SUBROUTINE +@cindex FUNCTION statement +@cindex statements, FUNCTION +@cindex signature of procedures + +Currently, @code{g77} passes arguments via reference---specifically, +by passing a pointer to the location in memory of a variable, array, +array element, a temporary location that holds the result of evaluating an +expression, or a temporary or permanent location that holds the value +of a constant. + +Procedures that accept @code{CHARACTER} arguments are implemented by +@code{g77} so that each @code{CHARACTER} argument has two actual arguments. + +The first argument occupies the expected position in the +argument list and has the user-specified name. +This argument +is a pointer to an array of characters, passed by the caller. + +The second argument is appended to the end of the user-specified +calling sequence and is named @samp{__g77_length_@var{x}}, where @var{x} +is the user-specified name. +This argument is of the C type @code{ftnlen} +(see @file{gcc/f/runtime/f2c.h.in} for information on that type) and +is the number of characters the caller has allocated in the +array pointed to by the first argument. + +A procedure will ignore the length argument if @samp{X} is not declared +@code{CHARACTER*(*)}, because for other declarations, it knows the +length. +Not all callers necessarily ``know'' this, however, which +is why they all pass the extra argument. + +The contents of the @code{CHARACTER} argument are specified by the +address passed in the first argument (named after it). +The procedure can read or write these contents as appropriate. + +When more than one @code{CHARACTER} argument is present in the argument +list, the length arguments are appended in the order +the original arguments appear. +So @samp{CALL FOO('HI','THERE')} is implemented in +C as @samp{foo("hi","there",2,5);}, ignoring the fact that @code{g77} +does not provide the trailing null bytes on the constant +strings (@code{f2c} does provide them, but they are unnecessary in +a Fortran environment, and you should not expect them to be +there). + +Note that the above information applies to @code{CHARACTER} variables and +arrays @strong{only}. +It does @strong{not} apply to external @code{CHARACTER} +functions or to intrinsic @code{CHARACTER} functions. +That is, no second length argument is passed to @samp{FOO} in this case: + +@example +CHARACTER X +EXTERNAL X +CALL FOO(X) +@end example + +@noindent +Nor does @samp{FOO} expect such an argument in this case: + +@example +SUBROUTINE FOO(X) +CHARACTER X +EXTERNAL X +@end example + +Because of this implementation detail, if a program has a bug +such that there is disagreement as to whether an argument is +a procedure, and the type of the argument is @code{CHARACTER}, subtle +symptoms might appear. + +@node Functions +@section Functions (FUNCTION and RETURN) +@cindex functions +@cindex FUNCTION statement +@cindex statements, FUNCTION +@cindex RETURN statement +@cindex statements, RETURN +@cindex return type of functions + +@code{g77} handles in a special way functions that return the following +types: + +@itemize @bullet +@item +@code{CHARACTER} +@item +@code{COMPLEX} +@item +@code{REAL(KIND=1)} +@end itemize + +For @code{CHARACTER}, @code{g77} implements a subroutine (a C function +returning @code{void}) +with two arguments prepended: @samp{__g77_result}, which the caller passes +as a pointer to a @code{char} array expected to hold the return value, +and @samp{__g77_length}, which the caller passes as an @code{ftnlen} value +specifying the length of the return value as declared in the calling +program. +For @code{CHARACTER*(*)}, the called function uses @samp{__g77_length} +to determine the size of the array that @samp{__g77_result} points to; +otherwise, it ignores that argument. + +For @code{COMPLEX}, when @samp{-ff2c} is in +force, @code{g77} implements +a subroutine with one argument prepended: @samp{__g77_result}, which the +caller passes as a pointer to a variable of the type of the function. +The called function writes the return value into this variable instead +of returning it as a function value. +When @samp{-fno-f2c} is in force, +@code{g77} implements a @code{COMPLEX} function as @code{gcc}'s +@samp{__complex__ float} or @samp{__complex__ double} function +(or an emulation thereof, when @samp{-femulate-complex} is in effect), +returning the result of the function in the same way as @code{gcc} would. + +For @code{REAL(KIND=1)}, when @samp{-ff2c} is in force, @code{g77} implements +a function that actually returns @code{REAL(KIND=2)} (typically +C's @code{double} type). +When @samp{-fno-f2c} is in force, @code{REAL(KIND=1)} +functions return @code{float}. + +@node Names +@section Names +@cindex symbol names +@cindex transformation of symbol names + +Fortran permits each implementation to decide how to represent +names as far as how they're seen in other contexts, such as debuggers +and when interfacing to other languages, and especially as far +as how casing is handled. + +External names---names of entities that are public, or ``accessible'', +to all modules in a program---normally have an underscore (@samp{_}) +appended by @code{g77}, to generate code that is compatible with f2c. +External names include names of Fortran things like common blocks, +external procedures (subroutines and functions, but not including +statement functions, which are internal procedures), and entry point +names. + +However, use of the @samp{-fno-underscoring} option +disables this kind of transformation of external names (though inhibiting +the transformation certainly improves the chances of colliding with +incompatible externals written in other languages---but that +might be intentional. + +@cindex -fno-underscoring option +@cindex options, -fno-underscoring +@cindex -fno-second-underscore option +@cindex options, -fno-underscoring +When @samp{-funderscoring} is in force, any name (external or local) +that already has at least one underscore in it is +implemented by @code{g77} by appending two underscores. +(This second underscore can be disabled via the +@samp{-fno-second-underscore} option.)@ +External names are changed this way for @code{f2c} compatibility. +Local names are changed this way to avoid collisions with external names +that are different in the source code---@code{f2c} does the same thing, but +there's no compatibility issue there except for user expectations while +debugging. + +For example: + +@example +Max_Cost = 0 +@end example + +@cindex debugging +@noindent +Here, a user would, in the debugger, refer to this variable using the +name @samp{max_cost__} (or @samp{MAX_COST__} or @samp{Max_Cost__}, +as described below). +(We hope to improve @code{g77} in this regard in the future---don't +write scripts depending on this behavior! +Also, consider experimenting with the @samp{-fno-underscoring} +option to try out debugging without having to massage names by +hand like this.) + +@code{g77} provides a number of command-line options that allow the user +to control how case mapping is handled for source files. +The default is the traditional UNIX model for Fortran compilers---names +are mapped to lower case. +Other command-line options can be specified to map names to upper +case, or to leave them exactly as written in the source file. + +For example: + +@example +Foo = 9.436 +@end example + +@noindent +Here, it is normally the case that the variable assigned will be named +@samp{foo}. +This would be the name to enter when using a debugger to +access the variable. + +However, depending on the command-line options specified, the +name implemented by @code{g77} might instead be @samp{FOO} or even +@samp{Foo}, thus affecting how debugging is done. + +Also: + +@example +Call Foo +@end example + +@noindent +This would normally call a procedure that, if it were in a separate C program, +be defined starting with the line: + +@example +void foo_() +@end example + +@noindent +However, @code{g77} command-line options could be used to change the casing +of names, resulting in the name @samp{FOO_} or @samp{Foo_} being given to the +procedure instead of @samp{foo_}, and the @samp{-fno-underscoring} option +could be used to inhibit the appending of the underscore to the name. + +@node Common Blocks +@section Common Blocks (COMMON) +@cindex common blocks +@cindex COMMON statement +@cindex statements, COMMON + +@code{g77} names and lays out @code{COMMON} areas the same way f2c does, +for compatibility with f2c. + +Currently, @code{g77} does not emit ``true'' debugging information for +members of a @code{COMMON} area, due to an apparent bug in the GBE. + +(As of Version 0.5.19, @code{g77} emits debugging information for such +members in the form of a constant string specifying the base name of +the aggregate area and the offset of the member in bytes from the start +of the area. +Use the @samp{-fdebug-kludge} option to enable this behavior. +In @code{gdb}, use @samp{set language c} before printing the value +of the member, then @samp{set language fortran} to restore the default +language, since @code{gdb} doesn't provide a way to print a readable +version of a character string in Fortran language mode. + +This kludge will be removed in a future version of @code{g77} that, +in conjunction with a contemporary version of @code{gdb}, +properly supports Fortran-language debugging, including access +to members of @code{COMMON} areas.) + +@xref{Code Gen Options,,Options for Code Generation Conventions}, +for information on the @samp{-fdebug-kludge} option. + +Moreover, @code{g77} currently implements a @code{COMMON} area such that its +type is an array of the C @code{char} data type. + +So, when debugging, you must know the offset into a @code{COMMON} area +for a particular item in that area, and you have to take into +account the appropriate multiplier for the respective sizes +of the types (as declared in your code) for the items preceding +the item in question as compared to the size of the @code{char} type. + +For example, using default implicit typing, the statement + +@example +COMMON I(15), R(20), T +@end example + +@noindent +results in a public 144-byte @code{char} array named @samp{_BLNK__} +with @samp{I} placed at @samp{_BLNK__[0]}, @samp{R} at @samp{_BLNK__[60]}, +and @samp{T} at @samp{_BLNK__[140]}. +(This is assuming that the target machine for +the compilation has 4-byte @code{INTEGER(KIND=1)} and @code{REAL(KIND=1)} +types.) + +@node Local Equivalence Areas +@section Local Equivalence Areas (EQUIVALENCE) +@cindex equivalence areas +@cindex local equivalence areas +@cindex EQUIVALENCE statement +@cindex statements, EQUIVALENCE + +@code{g77} treats storage-associated areas involving a @code{COMMON} +block as explained in the section on common blocks. + +A local @code{EQUIVALENCE} area is a collection of variables and arrays +connected to each other in any way via @code{EQUIVALENCE}, none of which are +listed in a @code{COMMON} statement. + +Currently, @code{g77} does not emit ``true'' debugging information for +members in a local @code{EQUIVALENCE} area, due to an apparent bug in the GBE. + +(As of Version 0.5.19, @code{g77} does emit debugging information for such +members in the form of a constant string specifying the base name of +the aggregate area and the offset of the member in bytes from the start +of the area. +Use the @samp{-fdebug-kludge} option to enable this behavior. +In @code{gdb}, use @samp{set language c} before printing the value +of the member, then @samp{set language fortran} to restore the default +language, since @code{gdb} doesn't provide a way to print a readable +version of a character string in Fortran language mode. + +This kludge will be removed in a future version of @code{g77} that, +in conjunction with a contemporary version of @code{gdb}, +properly supports Fortran-language debugging, including access +to members of @code{EQUIVALENCE} areas.) + +@xref{Code Gen Options,,Options for Code Generation Conventions}, +for information on the @samp{-fdebug-kludge} option. + +Moreover, @code{g77} implements a local @code{EQUIVALENCE} area such that its +type is an array of the C @code{char} data type. + +The name @code{g77} gives this array of @code{char} type is @samp{__g77_equiv_@var{x}}, +where @var{x} is the name of the item that is placed at the beginning (offset 0) +of this array. +If more than one such item is placed at the beginning, @var{x} is +the name that sorts to the top in an alphabetical sort of the list of +such items. + +When debugging, you must therefore access members of @code{EQUIVALENCE} +areas by specifying the appropriate @samp{__g77_equiv_@var{x}} +array section with the appropriate offset. +See the explanation of debugging @code{COMMON} blocks +for info applicable to debugging local @code{EQUIVALENCE} areas. + +(@emph{Note:} @code{g77} version 0.5.18 and earlier chose the name +for @var{x} using a different method when more than one name was +in the list of names of entities placed at the beginning of the +array. +Though the documentation specified that the first name listed in +the @code{EQUIVALENCE} statements was chosen for @var{x}, @code{g77} +in fact chose the name using a method that was so complicated, +it seemed easier to change it to an alphabetical sort than to describe the +previous method in the documentation.) + +@node Complex Variables +@section Complex Variables (COMPLEX) +@cindex complex variables +@cindex imaginary part of complex +@cindex COMPLEX statement +@cindex statements, COMPLEX + +As of 0.5.20, @code{g77} defaults to handling @code{COMPLEX} types +(and related intrinsics, constants, functions, and so on) +in a manner that +makes direct debugging involving these types in Fortran +language mode difficult. + +Essentially, @code{g77} implements these types using an +internal construct similar to C's @code{struct}, at least +as seen by the @code{gcc} back end. + +Currently, the back end, when outputting debugging info with +the compiled code for the assembler to digest, does not detect +these @code{struct} types as being substitutes for Fortran +complex. +As a result, the Fortran language modes of debuggers such as +@code{gdb} see these types as C @code{struct} types, which +they might or might not support. + +Until this is fixed, switch to C language mode to work with +entities of @code{COMPLEX} type and then switch back to Fortran language +mode afterward. +(In @code{gdb}, this is accomplished via @samp{set lang c} and +either @samp{set lang fortran} or @samp{set lang auto}.) + +@emph{Note:} Compiling with the @samp{-fno-emulate-complex} option +avoids the debugging problem, but is known to cause other problems +like compiler crashes and generation of incorrect code, so it is +not recommended. + +@node Arrays +@section Arrays (DIMENSION) +@cindex DIMENSION statement +@cindex statements, DIMENSION +@cindex array ordering +@cindex ordering, array +@cindex column-major ordering +@cindex row-major ordering +@cindex arrays + +Fortran uses ``column-major ordering'' in its arrays. +This differs from other languages, such as C, which use ``row-major ordering''. +The difference is that, with Fortran, array elements adjacent to +each other in memory differ in the @emph{first} subscript instead of +the last; @samp{A(5,10,20)} immediately follows @samp{A(4,10,20)}, +whereas with row-major ordering it would follow @samp{A(5,10,19)}. + +This consideration +affects not only interfacing with and debugging Fortran code, +it can greatly affect how code is designed and written, especially +when code speed and size is a concern. + +Fortran also differs from C, a popular language for interfacing and +to support directly in debuggers, in the way arrays are treated. +In C, arrays are single-dimensional and have interesting relationships +to pointers, neither of which is true for Fortran. +As a result, dealing with Fortran arrays from within +an environment limited to C concepts can be challenging. + +For example, accessing the array element @samp{A(5,10,20)} is easy enough +in Fortran (use @samp{A(5,10,20)}), but in C some difficult machinations +are needed. +First, C would treat the A array as a single-dimension array. +Second, C does not understand low bounds for arrays as does Fortran. +Third, C assumes a low bound of zero (0), while Fortran defaults to a +low bound of one (1) and can supports an arbitrary low bound. +Therefore, calculations must be done +to determine what the C equivalent of @samp{A(5,10,20)} would be, and these +calculations require knowing the dimensions of @samp{A}. + +For @samp{DIMENSION A(2:11,21,0:29)}, the calculation of the offset of +@samp{A(5,10,20)} would be: + +@example + (5-2) ++ (10-1)*(11-2+1) ++ (20-0)*(11-2+1)*(21-1+1) += 4293 +@end example + +@noindent +So the C equivalent in this case would be @samp{a[4293]}. + +When using a debugger directly on Fortran code, the C equivalent +might not work, because some debuggers cannot understand the notion +of low bounds other than zero. However, unlike @code{f2c}, @code{g77} +does inform the GBE that a multi-dimensional array (like @samp{A} +in the above example) is really multi-dimensional, rather than a +single-dimensional array, so at least the dimensionality of the array +is preserved. + +Debuggers that understand Fortran should have no trouble with +non-zero low bounds, but for non-Fortran debuggers, especially +C debuggers, the above example might have a C equivalent of +@samp{a[4305]}. +This calculation is arrived at by eliminating the subtraction +of the lower bound in the first parenthesized expression on each +line---that is, for @samp{(5-2)} substitute @samp{(5)}, for @samp{(10-1)} +substitute @samp{(10)}, and for @samp{(20-0)} substitute @samp{(20)}. +Actually, the implication of +this can be that the expression @samp{*(&a[2][1][0] + 4293)} works fine, +but that @samp{a[20][10][5]} produces the equivalent of +@samp{*(&a[0][0][0] + 4305)} because of the missing lower bounds. + +Come to think of it, perhaps +the behavior is due to the debugger internally compensating for +the lower bounds by offsetting the base address of @samp{a}, leaving +@samp{&a} set lower, in this case, than @samp{&a[2][1][0]} (the address of +its first element as identified by subscripts equal to the +corresponding lower bounds). + +You know, maybe nobody really needs to use arrays. + +@node Adjustable Arrays +@section Adjustable Arrays (DIMENSION) +@cindex arrays, adjustable +@cindex adjustable arrays +@cindex arrays, automatic +@cindex automatic arrays +@cindex DIMENSION statement +@cindex statements, DIMENSION +@cindex dimensioning arrays +@cindex arrays, dimensioning + +Adjustable and automatic arrays in Fortran require the implementation +(in this +case, the @code{g77} compiler) to ``memorize'' the expressions that +dimension the arrays each time the procedure is invoked. +This is so that subsequent changes to variables used in those +expressions, made during execution of the procedure, do not +have any effect on the dimensions of those arrays. + +For example: + +@example +REAL ARRAY(5) +DATA ARRAY/5*2/ +CALL X(ARRAY, 5) +END +SUBROUTINE X(A, N) +DIMENSION A(N) +N = 20 +PRINT *, N, A +END +@end example + +@noindent +Here, the implementation should, when running the program, print something +like: + +@example +20 2. 2. 2. 2. 2. +@end example + +@noindent +Note that this shows that while the value of @samp{N} was successfully +changed, the size of the @samp{A} array remained at 5 elements. + +To support this, @code{g77} generates code that executes before any user +code (and before the internally generated computed @code{GOTO} to handle +alternate entry points, as described below) that evaluates each +(nonconstant) expression in the list of subscripts for an +array, and saves the result of each such evaluation to be used when +determining the size of the array (instead of re-evaluating the +expressions). + +So, in the above example, when @samp{X} is first invoked, code is +executed that copies the value of @samp{N} to a temporary. +And that same temporary serves as the actual high bound for the single +dimension of the @samp{A} array (the low bound being the constant 1). +Since the user program cannot (legitimately) change the value +of the temporary during execution of the procedure, the size +of the array remains constant during each invocation. + +For alternate entry points, the code @code{g77} generates takes into +account the possibility that a dummy adjustable array is not actually +passed to the actual entry point being invoked at that time. +In that case, the public procedure implementing the entry point +passes to the master private procedure implementing all the +code for the entry points a @code{NULL} pointer where a pointer to that +adjustable array would be expected. +The @code{g77}-generated code +doesn't attempt to evaluate any of the expressions in the subscripts +for an array if the pointer to that array is @code{NULL} at run time in +such cases. +(Don't depend on this particular implementation +by writing code that purposely passes @code{NULL} pointers where the +callee expects adjustable arrays, even if you know the callee +won't reference the arrays---nor should you pass @code{NULL} pointers +for any dummy arguments used in calculating the bounds of such +arrays or leave undefined any values used for that purpose in +COMMON---because the way @code{g77} implements these things might +change in the future!) + +@node Alternate Entry Points +@section Alternate Entry Points (ENTRY) +@cindex alternate entry points +@cindex entry points +@cindex ENTRY statement +@cindex statements, ENTRY + +The GBE does not understand the general concept of +alternate entry points as Fortran provides via the ENTRY statement. +@code{g77} gets around this by using an approach to compiling procedures +having at least one @code{ENTRY} statement that is almost identical to the +approach used by @code{f2c}. +(An alternate approach could be used that +would probably generate faster, but larger, code that would also +be a bit easier to debug.) + +Information on how @code{g77} implements @code{ENTRY} is provided for those +trying to debug such code. +The choice of implementation seems +unlikely to affect code (compiled in other languages) that interfaces +to such code. + +@code{g77} compiles exactly one public procedure for the primary entry +point of a procedure plus each @code{ENTRY} point it specifies, as usual. +That is, in terms of the public interface, there is no difference +between + +@example +SUBROUTINE X +END +SUBROUTINE Y +END +@end example + +@noindent +and: + +@example +SUBROUTINE X +ENTRY Y +END +@end example + +The difference between the above two cases lies in the code compiled +for the @samp{X} and @samp{Y} procedures themselves, plus the fact that, +for the second case, an extra internal procedure is compiled. + +For every Fortran procedure with at least one @code{ENTRY} +statement, @code{g77} compiles an extra procedure +named @samp{__g77_masterfun_@var{x}}, where @var{x} is +the name of the primary entry point (which, in the above case, +using the standard compiler options, would be @samp{x_} in C). + +This extra procedure is compiled as a private procedure---that is, +a procedure not accessible by name to separately compiled modules. +It contains all the code in the program unit, including the code +for the primary entry point plus for every entry point. +(The code for each public procedure is quite short, and explained later.) + +The extra procedure has some other interesting characteristics. + +The argument list for this procedure is invented by @code{g77}. +It contains +a single integer argument named @samp{__g77_which_entrypoint}, +passed by value (as in Fortran's @samp{%VAL()} intrinsic), specifying the +entry point index---0 for the primary entry point, 1 for the +first entry point (the first @code{ENTRY} statement encountered), 2 for +the second entry point, and so on. + +It also contains, for functions returning @code{CHARACTER} and +(when @samp{-ff2c} is in effect) @code{COMPLEX} functions, +and for functions returning different types among the +@code{ENTRY} statements (e.g. @samp{REAL FUNCTION R()} +containing @samp{ENTRY I()}), an argument named @samp{__g77_result} that +is expected at run time to contain a pointer to where to store +the result of the entry point. +For @code{CHARACTER} functions, this +storage area is an array of the appropriate number of characters; +for @code{COMPLEX} functions, it is the appropriate area for the return +type; for multiple-return-type functions, it is a union of all the supported return +types (which cannot include @code{CHARACTER}, since combining @code{CHARACTER} +and non-@code{CHARACTER} return types via @code{ENTRY} in a single function +is not supported by @code{g77}). + +For @code{CHARACTER} functions, the @samp{__g77_result} argument is followed +by yet another argument named @samp{__g77_length} that, at run time, +specifies the caller's expected length of the returned value. +Note that only @code{CHARACTER*(*)} functions and entry points actually +make use of this argument, even though it is always passed by +all callers of public @code{CHARACTER} functions (since the caller does not +generally know whether such a function is @code{CHARACTER*(*)} or whether +there are any other callers that don't have that information). + +The rest of the argument list is the union of all the arguments +specified for all the entry points (in their usual forms, e.g. +@code{CHARACTER} arguments have extra length arguments, all appended at +the end of this list). +This is considered the ``master list'' of +arguments. + +The code for this procedure has, before the code for the first +executable statement, code much like that for the following Fortran +statement: + +@smallexample + GOTO (100000,100001,100002), __g77_which_entrypoint +100000 @dots{}code for primary entry point@dots{} +100001 @dots{}code immediately following first ENTRY statement@dots{} +100002 @dots{}code immediately following second ENTRY statement@dots{} +@end smallexample + +@noindent +(Note that invalid Fortran statement labels and variable names +are used in the above example to highlight the fact that it +represents code generated by the @code{g77} internals, not code to be +written by the user.) + +It is this code that, when the procedure is called, picks which +entry point to start executing. + +Getting back to the public procedures (@samp{x} and @samp{Y} in the original +example), those procedures are fairly simple. +Their interfaces +are just like they would be if they were self-contained procedures +(without @code{ENTRY}), of course, since that is what the callers +expect. +Their code consists of simply calling the private +procedure, described above, with the appropriate extra arguments +(the entry point index, and perhaps a pointer to a multiple-type- +return variable, local to the public procedure, that contains +all the supported returnable non-character types). +For arguments +that are not listed for a given entry point that are listed for +other entry points, and therefore that are in the ``master list'' +for the private procedure, null pointers (in C, the @code{NULL} macro) +are passed. +Also, for entry points that are part of a multiple-type- +returning function, code is compiled after the call of the private +procedure to extract from the multi-type union the appropriate result, +depending on the type of the entry point in question, returning +that result to the original caller. + +When debugging a procedure containing alternate entry points, you +can either set a break point on the public procedure itself (e.g. +a break point on @samp{X} or @samp{Y}) or on the private procedure that +contains most of the pertinent code (e.g. @samp{__g77_masterfun_@var{x}}). +If you do the former, you should use the debugger's command to +``step into'' the called procedure to get to the actual code; with +the latter approach, the break point leaves you right at the +actual code, skipping over the public entry point and its call +to the private procedure (unless you have set a break point there +as well, of course). + +Further, the list of dummy arguments that is visible when the +private procedure is active is going to be the expanded version +of the list for whichever particular entry point is active, +as explained above, and the way in which return values are +handled might well be different from how they would be handled +for an equivalent single-entry function. + +@node Alternate Returns +@section Alternate Returns (SUBROUTINE and RETURN) +@cindex subroutines +@cindex alternate returns +@cindex SUBROUTINE statement +@cindex statements, SUBROUTINE +@cindex RETURN statement +@cindex statements, RETURN + +Subroutines with alternate returns (e.g. @samp{SUBROUTINE X(*)} and +@samp{CALL X(*50)}) are implemented by @code{g77} as functions returning +the C @code{int} type. +The actual alternate-return arguments are omitted from the calling sequence. +Instead, the caller uses +the return value to do a rough equivalent of the Fortran +computed-@code{GOTO} statement, as in @samp{GOTO (50), X()} in the +example above (where @samp{X} is quietly declared as an @code{INTEGER(KIND=1)} +function), and the callee just returns whatever integer +is specified in the @code{RETURN} statement for the subroutine +For example, @samp{RETURN 1} is implemented as @samp{X = 1} followed +by @samp{RETURN} +in C, and @samp{RETURN} by itself is @samp{X = 0} and @samp{RETURN}). + +@node Assigned Statement Labels +@section Assigned Statement Labels (ASSIGN and GOTO) +@cindex assigned statement labels +@cindex statement labels, assigned +@cindex ASSIGN statement +@cindex statements, ASSIGN +@cindex GOTO statement +@cindex statements, GOTO + +For portability to machines where a pointer (such as to a label, +which is how @code{g77} implements @code{ASSIGN} and its relatives, +the assigned-@code{GOTO} and assigned-@code{FORMAT}-I/O statements) +is wider (bitwise) than an @code{INTEGER(KIND=1)}, @code{g77} +uses a different memory location to hold the @code{ASSIGN}ed value of a variable +than it does the numerical value in that variable, unless the +variable is wide enough (can hold enough bits). + +In particular, while @code{g77} implements + +@example +I = 10 +@end example + +@noindent +as, in C notation, @samp{i = 10;}, it implements + +@example +ASSIGN 10 TO I +@end example + +@noindent +as, in GNU's extended C notation (for the label syntax), +@samp{__g77_ASSIGN_I = &&L10;} (where @samp{L10} is just a massaging +of the Fortran label @samp{10} to make the syntax C-like; @code{g77} doesn't +actually generate the name @samp{L10} or any other name like that, +since debuggers cannot access labels anyway). + +While this currently means that an @code{ASSIGN} statement does not +overwrite the numeric contents of its target variable, @emph{do not} +write any code depending on this feature. +@code{g77} has already changed this implementation across +versions and might do so in the future. +This information is provided only to make debugging Fortran programs +compiled with the current version of @code{g77} somewhat easier. +If there's no debugger-visible variable named @samp{__g77_ASSIGN_I} +in a program unit that does @samp{ASSIGN 10 TO I}, that probably +means @code{g77} has decided it can store the pointer to the label directly +into @samp{I} itself. + +@xref{Ugly Assigned Labels}, for information on a command-line option +to force @code{g77} to use the same storage for both normal and +assigned-label uses of a variable. + +@node Run-time Library Errors +@section Run-time Library Errors +@cindex IOSTAT= +@cindex error values +@cindex error messages +@cindex messages, run-time +@cindex I/O, errors + +The @code{libf2c} library currently has the following table to relate +error code numbers, returned in @code{IOSTAT=} variables, to messages. +This information should, in future versions of this document, be +expanded upon to include detailed descriptions of each message. + +In line with good coding practices, any of the numbers in the +list below should @emph{not} be directly written into Fortran +code you write. +Instead, make a separate @code{INCLUDE} file that defines +@code{PARAMETER} names for them, and use those in your code, +so you can more easily change the actual numbers in the future. + +The information below is culled from the definition +of @samp{F_err} in @file{f/runtime/libI77/err.c} in the +@code{g77} source tree. + +@smallexample +100: "error in format" +101: "illegal unit number" +102: "formatted io not allowed" +103: "unformatted io not allowed" +104: "direct io not allowed" +105: "sequential io not allowed" +106: "can't backspace file" +107: "null file name" +108: "can't stat file" +109: "unit not connected" +110: "off end of record" +111: "truncation failed in endfile" +112: "incomprehensible list input" +113: "out of free space" +114: "unit not connected" +115: "read unexpected character" +116: "bad logical input field" +117: "bad variable type" +118: "bad namelist name" +119: "variable not in namelist" +120: "no end record" +121: "variable count incorrect" +122: "subscript for scalar variable" +123: "invalid array section" +124: "substring out of bounds" +125: "subscript out of bounds" +126: "can't read file" +127: "can't write file" +128: "'new' file exists" +129: "can't append to file" +130: "non-positive record number" +131: "I/O started while already doing I/O" +@end smallexample + +@node Collected Fortran Wisdom +@chapter Collected Fortran Wisdom +@cindex wisdom +@cindex legacy code +@cindex code, legacy +@cindex writing code +@cindex code, writing + +Most users of @code{g77} can be divided into two camps: + +@itemize @bullet +@item +Those writing new Fortran code to be compiled by @code{g77}. + +@item +Those using @code{g77} to compile existing, ``legacy'' code. +@end itemize + +Users writing new code generally understand most of the necessary +aspects of Fortran to write ``mainstream'' code, but often need +help deciding how to handle problems, such as the construction +of libraries containing @code{BLOCK DATA}. + +Users dealing with ``legacy'' code sometimes don't have much +experience with Fortran, but believe that the code they're compiling +already works when compiled by other compilers (and might +not understand why, as is sometimes the case, it doesn't work +when compiled by @code{g77}). + +The following information is designed to help users do a better job +coping with existing, ``legacy'' Fortran code, and with writing +new code as well. + +@menu +* Advantages Over f2c:: If @code{f2c} is so great, why @code{g77}? +* Block Data and Libraries:: How @code{g77} solves a common problem. +* Loops:: Fortran @code{DO} loops surprise many people. +* Working Programs:: Getting programs to work should be done first. +* Overly Convenient Options:: Temptations to avoid, habits to not form. +* Faster Programs:: Everybody wants these, but at what cost? +@end menu + +@node Advantages Over f2c +@section Advantages Over f2c + +Without @code{f2c}, @code{g77} would have taken much longer to +do and probably not been as good for quite a while. +Sometimes people who notice how much @code{g77} depends on, and +documents encouragement to use, @code{f2c} ask why @code{g77} +was created if @code{f2c} already existed. + +This section gives some basic answers to these questions, though it +is not intended to be comprehensive. + +@menu +* Language Extensions:: Features used by Fortran code. +* Compiler Options:: Features helpful during development. +* Compiler Speed:: Speed of the compilation process. +* Program Speed:: Speed of the generated, optimized code. +* Ease of Debugging:: Debugging ease-of-use at the source level. +* Character and Hollerith Constants:: A byte saved is a byte earned. +@end menu + +@node Language Extensions +@subsection Language Extensions + +@code{g77} offers several extensions to the Fortran language that @code{f2c} +doesn't. + +However, @code{f2c} offers a few that @code{g77} doesn't, like +fairly complete support for @code{INTEGER*2}. +It is expected that @code{g77} will offer some or all of these missing +features at some time in the future. +(Version 0.5.18 of @code{g77} offers some rudimentary support for some +of these features.) + +@node Compiler Options +@subsection Compiler Options + +@code{g77} offers a whole bunch of compiler options that @code{f2c} doesn't. + +However, @code{f2c} offers a few that @code{g77} doesn't, like an +option to generate code to check array subscripts at run time. +It is expected that @code{g77} will offer some or all of these +missing options at some time in the future. + +@node Compiler Speed +@subsection Compiler Speed + +Saving the steps of writing and then rereading C code is a big reason +why @code{g77} should be able to compile code much faster than using +@code{f2c} in conjunction with the equivalent invocation of @code{gcc}. + +However, due to @code{g77}'s youth, lots of self-checking is still being +performed. +As a result, this improvement is as yet unrealized +(though the potential seems to be there for quite a big speedup +in the future). +It is possible that, as of version 0.5.18, @code{g77} +is noticeably faster compiling many Fortran source files than using +@code{f2c} in conjunction with @code{gcc}. + +@node Program Speed +@subsection Program Speed + +@code{g77} has the potential to better optimize code than @code{f2c}, +even when @code{gcc} is used to compile the output of @code{f2c}, +because @code{f2c} must necessarily +translate Fortran into a somewhat lower-level language (C) that cannot +preserve all the information that is potentially useful for optimization, +while @code{g77} can gather, preserve, and transmit that information directly +to the GBE. + +For example, @code{g77} implements @code{ASSIGN} and assigned +@code{GOTO} using direct assignment of pointers to labels and direct +jumps to labels, whereas @code{f2c} maps the assigned labels to +integer values and then uses a C @code{switch} statement to encode +the assigned @code{GOTO} statements. + +However, as is typical, theory and reality don't quite match, at least +not in all cases, so it is still the case that @code{f2c} plus @code{gcc} +can generate code that is faster than @code{g77}. + +Version 0.5.18 of @code{g77} offered default +settings and options, via patches to the @code{gcc} +back end, that allow for better program speed, though +some of these improvements also affected the performance +of programs translated by @code{f2c} and then compiled +by @code{g77}'s version of @code{gcc}. + +Version 0.5.20 of @code{g77} offers further performance +improvements, at least one of which (alias analysis) is +not generally applicable to @code{f2c} (though @code{f2c} +could presumably be changed to also take advantage of +this new capability of the @code{gcc} back end, assuming +this is made available in an upcoming release of @code{gcc}). + +@node Ease of Debugging +@subsection Ease of Debugging + +Because @code{g77} compiles directly to assembler code like @code{gcc}, +instead of translating to an intermediate language (C) as does @code{f2c}, +support for debugging can be better for @code{g77} than @code{f2c}. + +However, although @code{g77} might be somewhat more ``native'' in terms of +debugging support than @code{f2c} plus @code{gcc}, there still are a lot +of things ``not quite right''. +Many of the important ones should be resolved in the near future. + +For example, @code{g77} doesn't have to worry about reserved names +like @code{f2c} does. +Given @samp{FOR = WHILE}, @code{f2c} must necessarily +translate this to something @emph{other} than +@samp{for = while;}, because C reserves those words. + +However, @code{g77} does still uses things like an extra level of indirection +for @code{ENTRY}-laden procedures---in this case, because the back end doesn't +yet support multiple entry points. + +Another example is that, given + +@smallexample +COMMON A, B +EQUIVALENCE (B, C) +@end smallexample + +@noindent +the @code{g77} user should be able to access the variables directly, by name, +without having to traverse C-like structures and unions, while @code{f2c} +is unlikely to ever offer this ability (due to limitations in the +C language). + +However, due to apparent bugs in the back end, @code{g77} currently doesn't +take advantage of this facility at all---it doesn't emit any debugging +information for @code{COMMON} and @code{EQUIVALENCE} areas, +other than information +on the array of @code{char} it creates (and, in the case +of local @code{EQUIVALENCE}, names) for each such area. + +Yet another example is arrays. +@code{g77} represents them to the debugger +using the same ``dimensionality'' as in the source code, while @code{f2c} +must necessarily convert them all to one-dimensional arrays to fit +into the confines of the C language. +However, the level of support +offered by debuggers for interactive Fortran-style access to arrays +as compiled by @code{g77} can vary widely. +In some cases, it can actually +be an advantage that @code{f2c} converts everything to widely supported +C semantics. + +In fairness, @code{g77} could do many of the things @code{f2c} does +to get things working at least as well as @code{f2c}---for now, +the developers prefer making @code{g77} work the +way they think it is supposed to, and finding help improving the +other products (the back end of @code{gcc}; @code{gdb}; and so on) +to get things working properly. + +@node Character and Hollerith Constants +@subsection Character and Hollerith Constants +@cindex character constants +@cindex constants, character +@cindex Hollerith constants +@cindex constants, Hollerith +@cindex trailing null byte +@cindex null byte, trailing +@cindex zero byte, trailing + +To avoid the extensive hassle that would be needed to avoid this, +@code{f2c} uses C character constants to encode character and Hollerith +constants. +That means a constant like @samp{'HELLO'} is translated to +@samp{"hello"} in C, which further means that an extra null byte is +present at the end of the constant. +This null byte is superfluous. + +@code{g77} does not generate such null bytes. +This represents significant +savings of resources, such as on systems where @file{/dev/null} or +@file{/dev/zero} represent bottlenecks in the systems' performance, +because @code{g77} simply asks for fewer zeros from the operating +system than @code{f2c}. + +@node Block Data and Libraries +@section Block Data and Libraries +@cindex block data and libraries +@cindex BLOCK DATA statement +@cindex statements, BLOCK DATA +@cindex libraries, containing BLOCK DATA +@cindex @code{f2c} compatibility +@cindex compatibility, @code{f2c} + +To ensure that block data program units are linked, especially a concern +when they are put into libraries, give each one a name (as in +@samp{BLOCK DATA FOO}) and make sure there is an @samp{EXTERNAL FOO} +statement in every program unit that uses any common block +initialized by the corresponding @code{BLOCK DATA}. +@code{g77} currently compiles a @code{BLOCK DATA} as if it were a +@code{SUBROUTINE}, +that is, it generates an actual procedure having the appropriate name. +The procedure does nothing but return immediately if it happens to be +called. +For @samp{EXTERNAL FOO}, where @samp{FOO} is not otherwise referenced in the +same program unit, @code{g77} assumes there exists a @samp{BLOCK DATA FOO} +in the program and ensures that by generating a +reference to it so the linker will make sure it is present. +(Specifically, @code{g77} outputs in the data section a static pointer to the +external name @samp{FOO}.) + +The implementation @code{g77} currently uses to make this work is +one of the few things not compatible with @code{f2c} as currently +shipped. +@code{f2c} currently does nothing with @samp{EXTERNAL FOO} except +issue a warning that @samp{FOO} is not otherwise referenced, and for +@samp{BLOCK DATA FOO}, f2c doesn't generate a dummy procedure with the +name @samp{FOO}. +The upshot is that you shouldn't mix @code{f2c} and @code{g77} in +this particular case. +If you use f2c to compile @samp{BLOCK DATA FOO}, +then any @code{g77}-compiled program unit that says @samp{EXTERNAL FOO} +will result in an unresolved reference when linked. +If you do the +opposite, then @samp{FOO} might not be linked in under various +circumstances (such as when @samp{FOO} is in a library, or you're +using a ``clever'' linker---so clever, it produces a broken program +with little or no warning by omitting initializations of global data +because they are contained in unreferenced procedures). + +The changes you make to your code to make @code{g77} handle this situation, +however, appear to be a widely portable way to handle it. +That is, many systems permit it (as they should, since the +FORTRAN 77 standard permits @samp{EXTERNAL FOO} when @samp{FOO} +is a block data program unit), and of the ones +that might not link @samp{BLOCK DATA FOO} under some circumstances, most of +them appear to do so once @samp{EXTERNAL FOO} is present in the appropriate +program units. + +Here is the recommended approach to modifying a program containing +a program unit such as the following: + +@smallexample +BLOCK DATA FOO +COMMON /VARS/ X, Y, Z +DATA X, Y, Z / 3., 4., 5. / +END +@end smallexample + +@noindent +If the above program unit might be placed in a library module, then +ensure that every program unit in every program that references that +particular @code{COMMON} area uses the @code{EXTERNAL} statement +to force the area to be initialized. + +For example, change a program unit that starts with + +@smallexample +INTEGER FUNCTION CURX() +COMMON /VARS/ X, Y, Z +CURX = X +END +@end smallexample + +@noindent +so that it uses the @code{EXTERNAL} statement, as in: + +@smallexample +INTEGER FUNCTION CURX() +COMMON /VARS/ X, Y, Z +EXTERNAL FOO +CURX = X +END +@end smallexample + +@noindent +That way, @samp{CURX} is compiled by @code{g77} (and many other +compilers) so that the linker knows it must include @samp{FOO}, +the @code{BLOCK DATA} program unit that sets the initial values +for the variables in @samp{VAR}, in the executable program. + +@node Loops +@section Loops +@cindex DO statement +@cindex statements, DO +@cindex trips, number of +@cindex number of trips + +The meaning of a @code{DO} loop in Fortran is precisely specified +in the Fortran standard@dots{}and is quite different from what +many programmers might expect. + +In particular, Fortran @code{DO} loops are implemented as if +the number of trips through the loop is calculated @emph{before} +the loop is entered. + +The number of trips for a loop is calculated from the @var{start}, +@var{end}, and @var{increment} values specified in a statement such as: + +@smallexample +DO @var{iter} = @var{start}, @var{end}, @var{increment} +@end smallexample + +@noindent +The trip count is evaluated using a fairly simple formula +based on the three values following the @samp{=} in the +statement, and it is that trip count that is effectively +decremented during each iteration of the loop. +If, at the beginning of an iteration of the loop, the +trip count is zero or negative, the loop terminates. +The per-loop-iteration modifications to @var{iter} are not +related to determining whether to terminate the loop. + +There are two important things to remember about the trip +count: + +@itemize @bullet +@item +It can be @emph{negative}, in which case it is +treated as if it was zero---meaning the loop is +not executed at all. + +@item +The type used to @emph{calculate} the trip count +is the same type as @var{iter}, but the final +calculation, and thus the type of the trip +count itself, always is @code{INTEGER(KIND=1)}. +@end itemize + +These two items mean that there are loops that cannot +be written in straightforward fashion using the Fortran @code{DO}. + +For example, on a system with the canonical 32-bit two's-complement +implementation of @code{INTEGER(KIND=1)}, the following loop will not work: + +@smallexample +DO I = -2000000000, 2000000000 +@end smallexample + +@noindent +Although the @var{start} and @var{end} values are well within +the range of @code{INTEGER(KIND=1)}, the @emph{trip count} is not. +The expected trip count is 40000000001, which is outside +the range of @code{INTEGER(KIND=1)} on many systems. + +Instead, the above loop should be constructed this way: + +@smallexample +I = -2000000000 +DO + IF (I .GT. 2000000000) EXIT + @dots{} + I = I + 1 +END DO +@end smallexample + +@noindent +The simple @code{DO} construct and the @code{EXIT} statement +(used to leave the innermost loop) +are F90 features that @code{g77} supports. + +Some Fortran compilers have buggy implementations of @code{DO}, +in that they don't follow the standard. +They implement @code{DO} as a straightforward translation +to what, in C, would be a @code{for} statement. +Instead of creating a temporary variable to hold the trip count +as calculated at run time, these compilers +use the iteration variable @var{iter} to control +whether the loop continues at each iteration. + +The bug in such an implementation shows up when the +trip count is within the range of the type of @var{iter}, +but the magnitude of @samp{ABS(@var{end}) + ABS(@var{incr})} +exceeds that range. For example: + +@smallexample +DO I = 2147483600, 2147483647 +@end smallexample + +@noindent +A loop started by the above statement will work as implemented +by @code{g77}, but the use, by some compilers, of a +more C-like implementation akin to + +@smallexample +for (i = 2147483600; i <= 2147483647; ++i) +@end smallexample + +@noindent +produces a loop that does not terminate, because @samp{i} +can never be greater than 2147483647, since incrementing it +beyond that value overflows @samp{i}, setting it to -2147483648. +This is a large, negative number that still is less than 2147483647. + +Another example of unexpected behavior of @code{DO} involves +using a nonintegral iteration variable @var{iter}, that is, +a @code{REAL} variable. +Consider the following program: + +@smallexample + DATA BEGIN, END, STEP /.1, .31, .007/ + DO 10 R = BEGIN, END, STEP + IF (R .GT. END) PRINT *, R, ' .GT. ', END, '!!' + PRINT *,R +10 CONTINUE + PRINT *,'LAST = ',R + IF (R .LE. END) PRINT *, R, ' .LE. ', END, '!!' + END +@end smallexample + +@noindent +A C-like view of @code{DO} would hold that the two ``exclamatory'' +@code{PRINT} statements are never executed. +However, this is the output of running the above program +as compiled by @code{g77} on a GNU/Linux ix86 system: + +@smallexample + .100000001 + .107000001 + .114 + .120999999 + @dots{} + .289000005 + .296000004 + .303000003 +LAST = .310000002 + .310000002 .LE. .310000002!! +@end smallexample + +Note that one of the two checks in the program turned up +an apparent violation of the programmer's expectation---yet, +the loop is correctly implemented by @code{g77}, in that +it has 30 iterations. +This trip count of 30 is correct when evaluated using +the floating-point representations for the @var{begin}, +@var{end}, and @var{incr} values (.1, .31, .007) on GNU/Linux +ix86 are used. +On other systems, an apparently more accurate trip count +of 31 might result, but, nevertheless, @code{g77} is +faithfully following the Fortran standard, and the result +is not what the author of the sample program above +apparently expected. +(Such other systems might, for different values in the @code{DATA} +statement, violate the other programmer's expectation, +for example.) + +Due to this combination of imprecise representation +of floating-point values and the often-misunderstood +interpretation of @code{DO} by standard-conforming +compilers such as @code{g77}, use of @code{DO} loops +with @code{REAL} iteration +variables is not recommended. +Such use can be caught by specifying @samp{-Wsurprising}. +@xref{Warning Options}, for more information on this +option. + +@node Working Programs +@section Working Programs + +Getting Fortran programs to work in the first place can be +quite a challenge---even when the programs already work on +other systems, or when using other compilers. + +@code{g77} offers some facilities that might be useful for +tracking down bugs in such programs. + +@menu +* Not My Type:: +* Variables Assumed To Be Zero:: +* Variables Assumed To Be Saved:: +* Unwanted Variables:: +* Unused Arguments:: +* Surprising Interpretations of Code:: +* Aliasing Assumed To Work:: +* Output Assumed To Flush:: +* Large File Unit Numbers:: +@end menu + +@node Not My Type +@subsection Not My Type +@cindex mistyped variables +@cindex variables, mistyped +@cindex mistyped functions +@cindex functions, mistyped +@cindex implicit typing + +A fruitful source of bugs in Fortran source code is use, or +mis-use, of Fortran's implicit-typing feature, whereby the +type of a variable, array, or function is determined by the +first character of its name. + +Simple cases of this include statements like @samp{LOGX=9.227}, +without a statement such as @samp{REAL LOGX}. +In this case, @samp{LOGX} is implicitly given @code{INTEGER(KIND=1)} +type, with the result of the assignment being that it is given +the value @samp{9}. + +More involved cases include a function that is defined starting +with a statement like @samp{DOUBLE PRECISION FUNCTION IPS(@dots{})}. +Any caller of this function that does not also declare @samp{IPS} +as type @code{DOUBLE PRECISION} (or, in GNU Fortran, @code{REAL(KIND=2)}) +is likely to assume it returns +@code{INTEGER}, or some other type, leading to invalid results +or even program crashes. + +The @samp{-Wimplicit} option might catch failures to +properly specify the types of +variables, arrays, and functions in the code. + +However, in code that makes heavy use of Fortran's +implicit-typing facility, this option might produce so +many warnings about cases that are working, it would be +hard to find the one or two that represent bugs. +This is why so many experienced Fortran programmers strongly +recommend widespread use of the @code{IMPLICIT NONE} statement, +despite it not being standard FORTRAN 77, to completely turn +off implicit typing. +(@code{g77} supports @code{IMPLICIT NONE}, as do almost all +FORTRAN 77 compilers.) + +Note that @samp{-Wimplicit} catches only implicit typing of +@emph{names}. +It does not catch implicit typing of expressions such +as @samp{X**(2/3)}. +Such expressions can be buggy as well---in fact, @samp{X**(2/3)} +is equivalent to @samp{X**0}, due to the way Fortran expressions +are given types and then evaluated. +(In this particular case, the programmer probably wanted +@samp{X**(2./3.)}.) + +@node Variables Assumed To Be Zero +@subsection Variables Assumed To Be Zero +@cindex zero-initialized variables +@cindex variables assumed to be zero +@cindex uninitialized variables + +Many Fortran programs were developed on systems that provided +automatic initialization of all, or some, variables and arrays +to zero. +As a result, many of these programs depend, sometimes +inadvertently, on this behavior, though to do so violates +the Fortran standards. + +You can ask @code{g77} for this behavior by specifying the +@samp{-finit-local-zero} option when compiling Fortran code. +(You might want to specify @samp{-fno-automatic} as well, +to avoid code-size inflation for non-optimized compilations.) + +Note that a program that works better when compiled with the +@samp{-finit-local-zero} option +is almost certainly depending on a particular system's, +or compiler's, tendency to initialize some variables to zero. +It might be worthwhile finding such cases and fixing them, +using techniques such as compiling with the @samp{-O -Wuninitialized} +options using @code{g77}. + +@node Variables Assumed To Be Saved +@subsection Variables Assumed To Be Saved +@cindex variables retaining values across calls +@cindex saved variables +@cindex static variables + +Many Fortran programs were developed on systems that +saved the values of all, or some, variables and arrays +across procedure calls. +As a result, many of these programs depend, sometimes +inadvertently, on being able to assign a value to a +variable, perform a @code{RETURN} to a calling procedure, +and, upon subsequent invocation, reference the previously +assigned variable to obtain the value. + +They expect this despite not using the @code{SAVE} statement +to specify that the value in a variable is expected to survive +procedure returns and calls. +Depending on variables and arrays to retain values across +procedure calls without using @code{SAVE} to require it violates +the Fortran standards. + +You can ask @code{g77} to assume @code{SAVE} is specified for all +relevant (local) variables and arrays by using the +@samp{-fno-automatic} option. + +Note that a program that works better when compiled with the +@samp{-fno-automatic} option +is almost certainly depending on not having to use +the @code{SAVE} statement as required by the Fortran standard. +It might be worthwhile finding such cases and fixing them, +using techniques such as compiling with the @samp{-O -Wuninitialized} +options using @code{g77}. + +@node Unwanted Variables +@subsection Unwanted Variables + +The @samp{-Wunused} option can find bugs involving +implicit typing, sometimes +more easily than using @samp{-Wimplicit} in code that makes +heavy use of implicit typing. +An unused variable or array might indicate that the +spelling for its declaration is different from that of +its intended uses. + +Other than cases involving typos, unused variables rarely +indicate actual bugs in a program. +However, investigating such cases thoroughly has, on occasion, +led to the discovery of code that had not been completely +written---where the programmer wrote declarations as needed +for the whole algorithm, wrote some or even most of the code +for that algorithm, then got distracted and forgot that the +job was not complete. + +@node Unused Arguments +@subsection Unused Arguments +@cindex unused arguments +@cindex arguments, unused + +As with unused variables, It is possible that unused arguments +to a procedure might indicate a bug. +Compile with @samp{-W -Wunused} option to catch cases of +unused arguments. + +Note that @samp{-W} also enables warnings regarding overflow +of floating-point constants under certain circumstances. + +@node Surprising Interpretations of Code +@subsection Surprising Interpretations of Code + +The @samp{-Wsuprising} option can help find bugs involving +expression evaluation or in +the way @code{DO} loops with non-integral iteration variables +are handled. +Cases found by this option might indicate a difference of +interpretation between the author of the code involved, and +a standard-conforming compiler such as @code{g77}. +Such a difference might produce actual bugs. + +In any case, changing the code to explicitly do what the +programmer might have expected it to do, so @code{g77} and +other compilers are more likely to follow the programmer's +expectations, might be worthwhile, especially if such changes +make the program work better. + +@node Aliasing Assumed To Work +@subsection Aliasing Assumed To Work +@cindex -falias-check option +@cindex options, -falias-check +@cindex -fargument-alias option +@cindex options, -fargument-alias +@cindex -fargument-noalias option +@cindex options, -fargument-noalias +@cindex -fno-argument-noalias-global option +@cindex options, -fno-argument-noalias-global +@cindex aliasing +@cindex anti-aliasing +@cindex overlapping arguments +@cindex overlays +@cindex association, storage +@cindex storage association +@cindex scheduling of reads and writes +@cindex reads and writes, scheduling + +The @samp{-falias-check}, @samp{-fargument-alias}, +@samp{-fargument-noalias}, +and @samp{-fno-argument-noalias-global} options, +introduced in version 0.5.20 and +@code{g77}'s version 2.7.2.2.f.2 of @code{gcc}, +control the assumptions regarding aliasing +(overlapping) +of writes and reads to main memory (core) made +by the @code{gcc} back end. + +They are effective only when compiling with @samp{-O} (specifying +any level other than @samp{-O0}) or with @samp{-falias-check}. + +The default for Fortran code is @samp{-fargument-noalias-global}. +(The default for C code and code written in other C-based languages +is @samp{-fargument-alias}. +These defaults apply regardless of whether you use @code{g77} or +@code{gcc} to compile your code.) + +Note that, on some systems, compiling with @samp{-fforce-addr} in +effect can produce more optimal code when the default aliasing +options are in effect (and when optimization is enabled). + +If your program is not working when compiled with optimization, +it is possible it is violating the Fortran standards (77 and 90) +by relying on the ability to ``safely'' modify variables and +arrays that are aliased, via procedure calls, to other variables +and arrays, without using @code{EQUIVALENCE} to explicitly +set up this kind of aliasing. + +(The FORTRAN 77 standard's prohibition of this sort of +overlap, generally referred to therein as ``storage +assocation'', appears in Sections 15.9.3.6. +This prohibition allows implementations, such as @code{g77}, +to, for example, implement the passing of procedures and +even values in @code{COMMON} via copy operations into local, +perhaps more efficiently accessed temporaries at entry to a +procedure, and, where appropriate, via copy operations back +out to their original locations in memory at exit from that +procedure, without having to take into consideration the +order in which the local copies are updated by the code, +among other things.) + +To test this hypothesis, try compiling your program with +the @samp{-fargument-alias} option, which causes the +compiler to revert to assumptions essentially the same as +made by versions of @code{g77} prior to 0.5.20. + +If the program works using this option, that strongly suggests +that the bug is in your program. +Finding and fixing the bug(s) should result in a program that +is more standard-conforming and that can be compiled by @code{g77} +in a way that results in a faster executable. + +(You might want to try compiling with @samp{-fargument-noalias}, +a kind of half-way point, to see if the problem is limited to +aliasing between dummy arguments and @code{COMMON} variables---this +option assumes that such aliasing is not done, while still allowing +aliasing among dummy arguments.) + +An example of aliasing that is invalid according to the standards +is shown in the following program, which might @emph{not} produce +the expected results when executed: + +@smallexample +I = 1 +CALL FOO(I, I) +PRINT *, I +END + +SUBROUTINE FOO(J, K) +J = J + K +K = J * K +PRINT *, J, K +END +@end smallexample + +The above program attempts to use the temporary aliasing of the +@samp{J} and @samp{K} arguments in @samp{FOO} to effect a +pathological behavior---the simultaneous changing of the values +of @emph{both} @samp{J} and @samp{K} when either one of them +is written. + +The programmer likely expects the program to print these values: + +@example +2 4 +4 +@end example + +However, since the program is not standard-conforming, an +implementation's behavior when running it is undefined, because +subroutine @samp{FOO} modifies at least one of the arguments, +and they are aliased with each other. +(Even if one of the assignment statements was deleted, the +program would still violate these rules. +This kind of on-the-fly aliasing is permitted by the standard +only when none of the aliased items are defined, or written, +while the aliasing is in effect.) + +As a practical example, an optimizing compiler might schedule +the @samp{J =} part of the second line of @samp{FOO} @emph{after} +the reading of @samp{J} and @samp{K} for the @samp{J * K} expression, +resulting in the following output: + +@example +2 2 +2 +@end example + +Essentially, compilers are promised (by the standard and, therefore, +by programmers who write code they claim to be standard-conforming) +that if they cannot detect aliasing via static analysis of a single +program unit's @code{EQUIVALENCE} and @code{COMMON} statements, no +such aliasing exists. +In such cases, compilers are free to assume that an assignment to +one variable will not change the value of another variable, allowing +it to avoid generating code to re-read the value of the other +variable, to re-schedule reads and writes, and so on, to produce +a faster executable. + +The same promise holds true for arrays (as seen by the called +procedure)---an element of one dummy array cannot be aliased +with, or overlap, any element of another dummy array or be +in a @code{COMMON} area known to the procedure. + +(These restrictions apply only when the procedure defines, or +writes to, one of the aliased variables or arrays.) + +Unfortunately, there is no way to find @emph{all} possible cases of +violations of the prohibitions against aliasing in Fortran code. +Static analysis is certainly imperfect, as is run-time analysis, +since neither can catch all violations. +(Static analysis can catch all likely violations, and some that +might never actually happen, while run-time analysis can catch +only those violations that actually happen during a particular +run. +Neither approach can cope with programs mixing Fortran code with +routines written in other languages, however.) + +Currently, @code{g77} provides neither static nor run-time facilities +to detect any cases of this problem, although other products might. +Run-time facilities are more likely to be offered by future +versions of @code{g77}, though patches improving @code{g77} so that +it provides either form of detection are welcome. + +@node Output Assumed To Flush +@subsection Output Assumed To Flush +@cindex ALWAYS_FLUSH +@cindex synchronous write errors +@cindex disk full +@cindex flushing output +@cindex fflush() +@cindex I/O, flushing +@cindex output, flushing +@cindex writes, flushing +@cindex NFS +@cindex network file system + +For several versions prior to 0.5.20, @code{g77} configured its +version of the @code{libf2c} run-time library so that one of +its configuration macros, @samp{ALWAYS_FLUSH}, was defined. + +This was done as a result of a belief that many programs expected +output to be flushed to the operating system (under UNIX, via +the @code{fflush()} library call) with the result that errors, +such as disk full, would be immediately flagged via the +relevant @code{ERR=} and @code{IOSTAT=} mechanism. + +Because of the adverse effects this approach had on the performance +of many programs, @code{g77} no longer configures @code{libf2c} +to always flush output. + +If your program depends on this behavior, either insert the +appropriate @samp{CALL FLUSH} statements, or modify the sources +to the @code{libf2c}, rebuild and reinstall @code{g77}, and +relink your programs with the modified library. + +(Ideally, @code{libf2c} would offer the choice at run-time, so +that a compile-time option to @code{g77} or @code{f2c} could +result in generating the appropriate calls to flushing or +non-flushing library routines.) + +@xref{Always Flush Output}, for information on how to modify +the @code{g77} source tree so that a version of @code{libf2c} +can be built and installed with the @samp{ALWAYS_FLUSH} macro defined. + +@node Large File Unit Numbers +@subsection Large File Unit Numbers +@cindex MXUNIT +@cindex unit numbers +@cindex maximum unit number +@cindex illegal unit number +@cindex increasing maximum unit number + +If your program crashes at run time with a message including +the text @samp{illegal unit number}, that probably is +a message from the run-time library, @code{libf2c}, used, and +distributed with, @code{g77}. + +The message means that your program has attempted to use a +file unit number that is out of the range accepted by +@code{libf2c}. +Normally, this range is 0 through 99, and the high end +of the range is controlled by a @code{libf2c} source-file +macro named @samp{MXUNIT}. + +If you can easily change your program to use unit numbers +in the range 0 through 99, you should do so. + +Otherwise, see @ref{Larger File Unit Numbers}, for information on how +to change @samp{MXUNIT} in @code{libf2c} so you can build and +install a new version of @code{libf2c} that supports the larger +unit numbers you need. + +@emph{Note:} While @code{libf2c} places a limit on the range +of Fortran file-unit numbers, the underlying library and operating +system might impose different kinds of limits. +For example, some systems limit the number of files simultaneously +open by a running program. +Information on how to increase these limits should be found +in your system's documentation. + +@node Overly Convenient Options +@section Overly Convenient Command-line Options +@cindex overly convenient options +@cindex options, overly convenient + +These options should be used only as a quick-and-dirty way to determine +how well your program will run under different compilation models +without having to change the source. +Some are more problematic +than others, depending on how portable and maintainable you want the +program to be (and, of course, whether you are allowed to change it +at all is crucial). + +You should not continue to use these command-line options to compile +a given program, but rather should make changes to the source code: + +@table @code +@cindex -finit-local-zero option +@cindex options, -finit-local-zero +@item -finit-local-zero +(This option specifies that any uninitialized local variables +and arrays have default initialization to binary zeros.) + +Many other compilers do this automatically, which means lots of +Fortran code developed with those compilers depends on it. + +It is safer (and probably +would produce a faster program) to find the variables and arrays that +need such initialization and provide it explicitly via @code{DATA}, so that +@samp{-finit-local-zero} is not needed. + +Consider using @samp{-Wuninitialized} (which requires @samp{-O}) to +find likely candidates, but +do not specify @samp{-finit-local-zero} or @samp{-fno-automatic}, +or this technique won't work. + +@cindex -fno-automatic option +@cindex options, -fno-automatic +@item -fno-automatic +(This option specifies that all local variables and arrays +are to be treated as if they were named in @code{SAVE} statements.) + +Many other compilers do this automatically, which means lots of +Fortran code developed with those compilers depends on it. + +The effect of this is that all non-automatic variables and arrays +are made static, that is, not placed on the stack or in heap storage. +This might cause a buggy program to appear to work better. +If so, rather than relying on this command-line option (and hoping all +compilers provide the equivalent one), add @code{SAVE} +statements to some or all program unit sources, as appropriate. +Consider using @samp{-Wuninitialized} (which requires @samp{-O}) +to find likely candidates, but +do not specify @samp{-finit-local-zero} or @samp{-fno-automatic}, +or this technique won't work. + +The default is @samp{-fautomatic}, which tells @code{g77} to try +and put variables and arrays on the stack (or in fast registers) +where possible and reasonable. +This tends to make programs faster. + +@cindex automatic arrays +@cindex arrays, automatic +@emph{Note:} Automatic variables and arrays are not affected +by this option. +These are variables and arrays that are @emph{necessarily} automatic, +either due to explicit statements, or due to the way they are +declared. +Examples include local variables and arrays not given the +@code{SAVE} attribute in procedures declared @code{RECURSIVE}, +and local arrays declared with non-constant bounds (automatic +arrays). +Currently, @code{g77} supports only automatic arrays, not +@code{RECURSIVE} procedures or other means of explicitly +specifying that variables or arrays are automatic. + +@cindex -fugly option +@cindex options, -fugly +@item -fugly +Fix the source code so that @samp{-fno-ugly} will work. +Note that, for many programs, it is difficult to practically +avoid using the features enabled via @samp{-fugly-init}, and these +features pose the lowest risk of writing nonportable code, among the +various ``ugly'' features. + +@cindex -f@var{group}-intrinsics-hide option +@cindex options, -f@var{group}-intrinsics-hide +@item -f@var{group}-intrinsics-hide +Change the source code to use @code{EXTERNAL} for any external procedure +that might be the name of an intrinsic. +It is easy to find these using @samp{-f@var{group}-intrinsics-disable}. +@end table + +@node Faster Programs +@section Faster Programs +@cindex speeding up programs +@cindex programs, speeding up + +Aside from the usual @code{gcc} options, such as @samp{-O}, +@samp{-ffast-math}, and so on, consider trying some of the +following approaches to speed up your program (once you get +it working). + +@menu +* Aligned Data:: +* Prefer Automatic Uninitialized Variables:: +* Avoid f2c Compatibility:: +* Use Submodel Options:: +@end menu + +@node Aligned Data +@subsection Aligned Data +@cindex data, aligned +@cindex stack, aligned +@cindex aligned data +@cindex aligned stack +@cindex Pentium optimizations +@cindex optimizations, Pentium + +On some systems, such as those with Pentium Pro CPUs, programs +that make heavy use of @code{REAL(KIND=2)} (@code{DOUBLE PRECISION}) +might run much slower +than possible due to the compiler not aligning these 64-bit +values to 64-bit boundaries in memory. +(The effect also is present, though +to a lesser extent, on the 586 (Pentium) architecture.) + +The Intel x86 architecture generally ensures that these programs will +work on all its implementations, +but particular implementations (such as Pentium Pro) +perform better with more strict alignment. + +There are a variety of approaches to use to address this problem, +in any combination: + +@itemize @bullet +@item +Order your @code{COMMON} and @code{EQUIVALENCE} areas such +that the variables and arrays with the widest alignment +guidelines come first. + +For example, on most systems, this would mean placing +@code{COMPLEX(KIND=2)}, @code{REAL(KIND=2)}, and +@code{INTEGER(KIND=2)} entities first, followed by @code{REAL(KIND=1)}, +@code{INTEGER(KIND=1)}, and @code{LOGICAL(KIND=1)} entities, then +@code{INTEGER(KIND=6)} entities, and finally @code{CHARACTER} +and @code{INTEGER(KIND=3)} entities. + +The reason to use such placement is it makes it more likely +that your data will be aligned properly, without requiring +you to do detailed analysis of each aggregate (@code{COMMON} +and @code{EQUIVALENCE}) area. + +Specifically, on systems where the above guidelines are +appropriate, placing @code{CHARACTER} entities before +@code{REAL(KIND=2)} entities can work just as well, +but only if the number of bytes occupied by the @code{CHARACTER} +entities is divisible by the recommended alignment for +@code{REAL(KIND=2)}. + +By ordering the placement of entities in aggregate +areas according to the simple guidelines above, you +avoid having to carefully count the number of bytes +occupied by each entity to determine whether the +actual alignment of each subsequent entity meets the +alignment guidelines for the type of that entity. + +@item +Use the (x86-specific) @samp{-malign-double} option when compiling +programs. +This will align only static data (entities in @code{COMMON} or +local entities with the @code{SAVE} attribute), +but it should probably always be +used with Fortran code on the 586 and 686 architectures for best +performance. + +This feature of @samp{-malign-double} means it may actually be best to +use it with @samp{-fno-automatic} even though the latter usually +produces worse code; at least, doing so will tend to produce more +consistent run times. + +Using @samp{-malign-double} and @samp{-fno-automatic} together is +apparently the only way to ensure that all doubles are correctly aligned +on GNU x86 systems without having to change @code{g77} itself as +described in the next item. +(Note that the @code{gcc} C extension @samp{__attribute__ ((aligned (8))} +also won't double-align the datum to which it is applied if that is allocated +on the stack.) +It isn't clear whether this deficiency also applies to +non-GNU based x86 systems (Solaris, DGUX et al), but it probably does. + +@item +Change the definition of the @samp{STACK_BOUNDARY} macro in +@file{gcc/config/i386/i386.h} from @samp{32} to +@samp{(TARGET_ALIGN_DOUBLE ? 64 : 32)}, and rebuild +@code{g77}. +@xref{Installation,,Installing GNU Fortran}, for more information. + +@item +Ensure that @file{crt0.o} or @file{crt1.o} +on your system guarantees a 64-bit +aligned stack for @code{main()}. +Some experimentation might be needed to determine this, and +access to source code to fix this. +While arranging this may typically +get more data properly aligned, it won't, by itself, +ensure they all are. + +One approach to testing this is to write a @code{main()} program +in C or assembler that outputs the address of the stack pointer +(and/or frame pointer), and visually inspect the output to see +if the stack is 64-bit aligned. +If it is, try renaming the executable to longer and shorter names +and running the program again. +If the name of the executable is placed on the stack by @file{crt0.o} +or @file{crt1.o}, +the location of the stack should move, and this might help determine +whether it is kept on a 64-bit boundary. +@end itemize + +Yes, this is all more complicated than it should be. +The problems are best solved in @code{gcc} and the +libraries for the operating systems on such systems, +which need to be continuously updated to provide the +best alignment for newly released processors. +Managing this while remaining compatible with ABIs +on various systems can be challenging. + +@node Prefer Automatic Uninitialized Variables +@subsection Prefer Automatic Uninitialized Variables + +If you're using @samp{-fno-automatic} already, you probably +should change your code to allow compilation with @samp{-fautomatic} +(the default), to allow the program to run faster. + +Similarly, you should be able to use @samp{-fno-init-local-zero} +(the default) instead of @samp{-finit-local-zero}. +This is because it is rare that every variable affected by these +options in a given program actually needs to +be so affected. + +For example, @samp{-fno-automatic}, which effectively @code{SAVE}s +every local non-automatic variable and array, affects even things like +@code{DO} iteration +variables, which rarely need to be @code{SAVE}d, and this often reduces +run-time performances. +Similarly, @samp{-fno-init-local-zero} forces such +variables to be initialized to zero---when @code{SAVE}d (such as when +@samp{-fno-automatic}), this by itself generally affects only +startup time for a program, but when not @code{SAVE}d, +it can slow down the procedure every time it is called. + +@xref{Overly Convenient Options,,Overly Convenient Command-Line Options}, +for information on the @samp{-fno-automatic} and +@samp{-finit-local-zero} options and how to convert +their use into selective changes in your own code. + +@node Avoid f2c Compatibility +@subsection Avoid f2c Compatibility +@cindex -fno-f2c option +@cindex options, -fno-f2c +@cindex @code{f2c} compatibility +@cindex compatibility, @code{f2c} + +If you aren't linking with any code compiled using +@code{f2c}, try using the @samp{-fno-f2c} option when +compiling @emph{all} the code in your program. +(Note that @code{libf2c} is @emph{not} an example of code +that is compiled using @code{f2c}---it is compiled by a C +compiler, typically @code{gcc}.) + +@node Use Submodel Options +@subsection Use Submodel Options +@cindex Pentium optimizations +@cindex optimizations, Pentium +@cindex 586/686 CPUs +@cindex submodels + +Using an appropriate @samp{-m} option to generate specific code for your +CPU may be worthwhile, though it may mean the executable won't run on +other versions of the CPU that don't support the same instruction set. +@xref{Submodel Options,,Hardware Models and Configurations,gcc,Using and +Porting GNU CC}. + +For recent CPUs that don't have explicit support in +the released version of @code{gcc}, it may still be possible to get +improvements. +For instance, the flags recommended for 586/686 +(Pentium(Pro)) chips for building the Linux kernel are: + +@smallexample +-m486 -malign-loops=2 -malign-jumps=2 -malign-functions=2 +-fomit-frame-pointer +@end smallexample + +@noindent @samp{-fomit-frame-pointer} will, however, inhibit debugging +on x86 systems. + +@node Trouble +@chapter Known Causes of Trouble with GNU Fortran +@cindex bugs, known +@cindex installation trouble +@cindex known causes of trouble + +This section describes known problems that affect users of GNU Fortran. +Most of these are not GNU Fortran bugs per se---if they were, we would +fix them. +But the result for a user might be like the result of a bug. + +Some of these problems are due to bugs in other software, some are +missing features that are too much work to add, and some are places +where people's opinions differ as to what is best. + +Information on bugs that show up when configuring, porting, building, +or installing @code{g77} is not provided here. +@xref{Problems Installing}. + +To find out about major bugs discovered in the current release and +possible workarounds for them, retrieve +@url{ftp://alpha.gnu.ai.mit.edu/g77.plan}. + +(Note that some of this portion of the manual is lifted +directly from the @code{gcc} manual, with minor modifications +to tailor it to users of @code{g77}. +Anytime a bug seems to have more to do with the @code{gcc} +portion of @code{g77}, +@xref{Trouble,,Known Causes of Trouble with GNU CC, +gcc,Using and Porting GNU CC}.) + +@menu +* But-bugs:: Bugs really in other programs or elsewhere. +* Actual Bugs:: Bugs and misfeatures we will fix later. +* Missing Features:: Features we already know we want to add later. +* Disappointments:: Regrettable things we can't change. +* Non-bugs:: Things we think are right, but some others disagree. +* Warnings and Errors:: Which problems in your code get warnings, + and which get errors. +@end menu + +@node But-bugs +@section Bugs Not In GNU Fortran +@cindex but-bugs + +These are bugs to which the maintainers often have to reply, +``but that isn't a bug in @code{g77}@dots{}''. +Some of these already are fixed in new versions of other +software; some still need to be fixed; some are problems +with how @code{g77} is installed or is being used; +some are the result of bad hardware that causes software +to misbehave in sometimes bizarre ways; +some just cannot be addressed at this time until more +is known about the problem. + +Please don't re-report these bugs to the @code{g77} maintainers---if +you must remind someone how important it is to you that the problem +be fixed, talk to the people responsible for the other products +identified below, but preferably only after you've tried the +latest versions of those products. +The @code{g77} maintainers have their hands full working on +just fixing and improving @code{g77}, without serving as a +clearinghouse for all bugs that happen to affect @code{g77} +users. + +@xref{Collected Fortran Wisdom}, for information on behavior +of Fortran programs, and the programs that compile them, that +might be @emph{thought} to indicate bugs. + +@menu +* Signal 11 and Friends:: Strange behavior by any software. +* Cannot Link Fortran Programs:: Unresolved references. +* Large Common Blocks:: Problems on older GNU/Linux systems. +* Debugger Problems:: When the debugger crashes. +* NeXTStep Problems:: Misbehaving executables. +* Stack Overflow:: More misbehaving executables. +* Nothing Happens:: Less behaving executables. +* Strange Behavior at Run Time:: Executables misbehaving due to + bugs in your program. +* Floating-point Errors:: The results look wrong, but@dots{}. +@end menu + +@node Signal 11 and Friends +@subsection Signal 11 and Friends +@cindex signal 11 +@cindex hardware errors + +A whole variety of strange behaviors can occur when the +software, or the way you are using the software, +stresses the hardware in a way that triggers hardware bugs. +This might seem hard to believe, but it happens frequently +enough that there exist documents explaining in detail +what the various causes of the problems are, what +typical symptoms look like, and so on. + +Generally these problems are referred to in this document +as ``signal 11'' crashes, because the Linux kernel, running +on the most popular hardware (the Intel x86 line), often +stresses the hardware more than other popular operating +systems. +When hardware problems do occur under GNU/Linux on x86 +systems, these often manifest themselves as ``signal 11'' +problems, as illustrated by the following diagnostic: + +@smallexample +sh# @kbd{g77 myprog.f} +gcc: Internal compiler error: program f771 got fatal signal 11 +sh# +@end smallexample + +It is @emph{very} important to remember that the above +message is @emph{not} the only one that indicates a +hardware problem, nor does it always indicate a hardware +problem. + +In particular, on systems other than those running the Linux +kernel, the message might appear somewhat or very different, +as it will if the error manifests itself while running a +program other than the @code{g77} compiler. +For example, +it will appear somewhat different when running your program, +when running Emacs, and so on. + +How to cope with such problems is well beyond the scope +of this manual. + +However, users of Linux-based systems (such as GNU/Linux) +should review @url{http://www.bitwizard.nl/sig11}, a source +of detailed information on diagnosing hardware problems, +by recognizing their common symptoms. + +Users of other operating systems and hardware might +find this reference useful as well. +If you know of similar material for another hardware/software +combination, please let us know so we can consider including +a reference to it in future versions of this manual. + +@node Cannot Link Fortran Programs +@subsection Cannot Link Fortran Programs +@cindex unresolved reference (various) +@cindex linking error for user code +@cindex code, user +@cindex ld error for user code +@cindex ld can't find strange names +On some systems, perhaps just those with out-of-date (shared?) +libraries, unresolved-reference errors happen when linking @code{g77}-compiled +programs (which should be done using @code{g77}). + +If this happens to you, try appending @samp{-lc} to the command you +use to link the program, e.g. @samp{g77 foo.f -lc}. +@code{g77} already specifies @samp{-lf2c -lm} when it calls the linker, +but it cannot also specify @samp{-lc} because not all systems have a +file named @file{libc.a}. + +It is unclear at this point whether there are legitimately installed +systems where @samp{-lf2c -lm} is insufficient to resolve code produced +by @code{g77}. + +@cindex undefined reference (_main) +@cindex linking error for user code +@cindex ld error for user code +@cindex code, user +@cindex ld can't find _main +If your program doesn't link due to unresolved references to names +like @samp{_main}, make sure you're using the @code{g77} command to do the +link, since this command ensures that the necessary libraries are +loaded by specifying @samp{-lf2c -lm} when it invokes the @code{gcc} +command to do the actual link. +(Use the @samp{-v} option to discover +more about what actually happens when you use the @code{g77} and @code{gcc} +commands.) + +Also, try specifying @samp{-lc} as the last item on the @code{g77} +command line, in case that helps. + +@node Large Common Blocks +@subsection Large Common Blocks +@cindex common blocks, large +@cindex large common blocks +@cindex linker errors +@cindex ld errors +@cindex errors, linker +On some older GNU/Linux systems, programs with common blocks larger +than 16MB cannot be linked without some kind of error +message being produced. + +This is a bug in older versions of @code{ld}, fixed in +more recent versions of @code{binutils}, such as version 2.6. + +@node Debugger Problems +@subsection Debugger Problems +@cindex @code{gdb} support +@cindex support, @code{gdb} +There are some known problems when using @code{gdb} on code +compiled by @code{g77}. +Inadequate investigation as of the release of 0.5.16 results in not +knowing which products are the culprit, but @file{gdb-4.14} definitely +crashes when, for example, an attempt is made to print the contents +of a @code{COMPLEX(KIND=2)} dummy array, on at least some GNU/Linux machines, plus +some others. + +@node NeXTStep Problems +@subsection NeXTStep Problems +@cindex NeXTStep problems +@cindex bus error +@cindex segmentation violation +Developers of Fortran code on NeXTStep (all architectures) have to +watch out for the following problem when writing programs with +large, statically allocated (i.e. non-stack based) data structures +(common blocks, saved arrays). + +Due to the way the native loader (@file{/bin/ld}) lays out +data structures in virtual memory, it is very easy to create an +executable wherein the @samp{__DATA} segment overlaps (has addresses in +common) with the @samp{UNIX STACK} segment. + +This leads to all sorts of trouble, from the executable simply not +executing, to bus errors. +The NeXTStep command line tool @code{ebadexec} points to +the problem as follows: + +@smallexample +% @kbd{/bin/ebadexec a.out} +/bin/ebadexec: __LINKEDIT segment (truncated address = 0x3de000 +rounded size = 0x2a000) of executable file: a.out overlaps with UNIX +STACK segment (truncated address = 0x400000 rounded size = +0x3c00000) of executable file: a.out +@end smallexample + +(In the above case, it is the @samp{__LINKEDIT} segment that overlaps the +stack segment.) + +This can be cured by assigning the @samp{__DATA} segment +(virtual) addresses beyond the stack segment. +A conservative +estimate for this is from address 6000000 (hexadecimal) onwards---this +has always worked for me [Toon Moene]: + +@smallexample +% @kbd{g77 -segaddr __DATA 6000000 test.f} +% @kbd{ebadexec a.out} +ebadexec: file: a.out appears to be executable +% +@end smallexample + +Browsing through @file{gcc/f/Makefile.in}, +you will find that the @code{f771} program itself also has to be +linked with these flags---it has large statically allocated +data structures. +(Version 0.5.18 reduces this somewhat, but probably +not enough.) + +(The above item was contributed by Toon Moene +(@email{toon@@moene.indiv.nluug.nl}).) + +@node Stack Overflow +@subsection Stack Overflow +@cindex stack overflow +@cindex segmentation violation +@code{g77} code might fail at runtime (probably with a ``segmentation +violation'') due to overflowing the stack. +This happens most often on systems with an environment +that provides substantially more heap space (for use +when arbitrarily allocating and freeing memory) than stack +space. + +Often this can be cured by +increasing or removing your shell's limit on stack usage, typically +using @kbd{limit stacksize} (in @code{csh} and derivatives) or +@kbd{ulimit -s} (in @code{sh} and derivatives). + +Increasing the allowed stack size might, however, require +changing some operating system or system configuration parameters. + +You might be able to work around the problem by compiling with the +@samp{-fno-automatic} option to reduce stack usage, probably at the +expense of speed. + +@xref{Maximum Stackable Size}, for information on patching +@code{g77} to use different criteria for placing local +non-automatic variables and arrays on the stack. + +@cindex automatic arrays +@cindex arrays, automatic +However, if your program uses large automatic arrays +(for example, has declarations like @samp{REAL A(N)} where +@samp{A} is a local array and @samp{N} is a dummy or +@code{COMMON} variable that can have a large value), +neither use of @samp{-fno-automatic}, +nor changing the cut-off point for @code{g77} for using the stack, +will solve the problem by changing the placement of these +large arrays, as they are @emph{necessarily} automatic. + +@code{g77} currently provides no means to specify that +automatic arrays are to be allocated on the heap instead +of the stack. +So, other than increasing the stack size, your best bet is to +change your source code to avoid large automatic arrays. +Methods for doing this currently are outside the scope of +this document. + +(@emph{Note:} If your system puts stack and heap space in the +same memory area, such that they are effectively combined, then +a stack overflow probably indicates a program that is either +simply too large for the system, or buggy.) + +@node Nothing Happens +@subsection Nothing Happens +@cindex nothing happens +@cindex naming programs @samp{test} +@cindex @samp{test} programs +@cindex programs named @samp{test} +It is occasionally reported that a ``simple'' program, +such as a ``Hello, World!'' program, does nothing when +it is run, even though the compiler reported no errors, +despite the program containing nothing other than a +simple @code{PRINT} statement. + +This most often happens because the program has been +compiled and linked on a UNIX system and named @samp{test}, +though other names can lead to similarly unexpected +run-time behavior on various systems. + +Essentially this problem boils down to giving +your program a name that is already known to +the shell you are using to identify some other program, +which the shell continues to execute instead of your +program when you invoke it via, for example: + +@smallexample +sh# @kbd{test} +sh# +@end smallexample + +Under UNIX and many other system, a simple command name +invokes a searching mechanism that might well not choose +the program located in the current working directory if +there is another alternative (such as the @code{test} +command commonly installed on UNIX systems). + +The reliable way to invoke a program you just linked in +the current directory under UNIX is to specify it using +an explicit pathname, as in: + +@smallexample +sh# @kbd{./test} + Hello, World! +sh# +@end smallexample + +Users who encounter this problem should take the time to +read up on how their shell searches for commands, how to +set their search path, and so on. +The relevant UNIX commands to learn about include +@code{man}, @code{info} (on GNU systems), @code{setenv} (or +@code{set} and @code{env}), @code{which}, and @code{find}. + +@node Strange Behavior at Run Time +@subsection Strange Behavior at Run Time +@cindex segmentation violation +@cindex bus error +@cindex overwritten data +@cindex data, overwritten +@code{g77} code might fail at runtime with ``segmentation violation'', +``bus error'', or even something as subtle as a procedure call +overwriting a variable or array element that it is not supposed +to touch. + +These can be symptoms of a wide variety of actual bugs that +occurred earlier during the program's run, but manifested +themselves as @emph{visible} problems some time later. + +Overflowing the bounds of an array---usually by writing beyond +the end of it---is one of two kinds of bug that often occurs +in Fortran code. + +The other kind of bug is a mismatch between the actual arguments +passed to a procedure and the dummy arguments as declared by that +procedure. + +Both of these kinds of bugs, and some others as well, can be +difficult to track down, because the bug can change its behavior, +or even appear to not occur, when using a debugger. + +That is, these bugs can be quite sensitive to data, including +data representing the placement of other data in memory (that is, +pointers, such as the placement of stack frames in memory). + +Plans call for improving @code{g77} so that it can offer the +ability to catch and report some of these problems at compile, link, or +run time, such as by generating code to detect references to +beyond the bounds of an array, or checking for agreement between +calling and called procedures. + +In the meantime, finding and fixing the programming +bugs that lead to these behaviors is, ultimately, the user's +responsibility, as difficult as that task can sometimes be. + +@cindex `infinite spaces' printed +@cindex spaces, endless printing of +@cindex libc, non-ANSI or non-default +@cindex C library +@cindex linking against non-standard library +@cindex Solaris +One runtime problem that has been observed might have a simple solution. +If a formatted @code{WRITE} produces an endless stream of spaces, check +that your program is linked against the correct version of the C library. +The configuration process takes care to account for your +system's normal @file{libc} not being ANSI-standard, which will +otherwise cause this behaviour. +If your system's default library is +ANSI-standard and you subsequently link against a non-ANSI one, there +might be problems such as this one. + +Specifically, on Solaris2 systems, +avoid picking up the @code{BSD} library from @file{/usr/ucblib}. + +@node Floating-point Errors +@subsection Floating-point Errors +@cindex floating-point errors +@cindex rounding errors +@cindex inconsistent floating-point results +@cindex results, inconsistent +Some programs appear to produce inconsistent floating-point +results compiled by @code{g77} versus by other compilers. + +Often the reason for this behavior is the fact that floating-point +values are represented on almost all Fortran systems by +@emph{approximations}, and these approximations are inexact +even for apparently simple values like 0.1, 0.2, 0.3, 0.4, 0.6, +0.7, 0.8, 0.9, 1.1, and so on. +Most Fortran systems, including all current ports of @code{g77}, +use binary arithmetic to represent these approximations. + +Therefore, the exact value of any floating-point approximation +as manipulated by @code{g77}-compiled code is representable by +adding some combination of the values 1.0, 0.5, 0.25, 0.125, and +so on (just keep dividing by two) through the precision of the +fraction (typically around 23 bits for @code{REAL(KIND=1)}, 52 for +@code{REAL(KIND=2)}), then multiplying the sum by a integral +power of two (in Fortran, by @samp{2**N}) that typically is between +-127 and +128 for @code{REAL(KIND=1)} and -1023 and +1024 for +@code{REAL(KIND=2)}, then multiplying by -1 if the number +is negative. + +So, a value like 0.2 is exactly represented in decimal---since +it is a fraction, @samp{2/10}, with a denomenator that is compatible +with the base of the number system (base 10). +However, @samp{2/10} cannot be represented by any finite number +of sums of any of 1.0, 0.5, 0.25, and so on, so 0.2 cannot +be exactly represented in binary notation. + +(On the other hand, decimal notation can represent any binary +number in a finite number of digits. +Decimal notation cannot do so with ternary, or base-3, +notation, which would represent floating-point numbers as +sums of any of @samp{1/1}, @samp{1/3}, @samp{1/9}, and so on. +After all, no finite number of decimal digits can exactly +represent @samp{1/3}. +Fortunately, few systems use ternary notation.) + +Moreover, differences in the way run-time I/O libraries convert +between these approximations and the decimal representation often +used by programmers and the programs they write can result in +apparent differences between results that do not actually exist, +or exist to such a small degree that they usually are not worth +worrying about. + +For example, consider the following program: + +@smallexample +PRINT *, 0.2 +END +@end smallexample + +When compiled by @code{g77}, the above program might output +@samp{0.20000003}, while another compiler might produce a +executable that outputs @samp{0.2}. + +This particular difference is due to the fact that, currently, +conversion of floating-point values by the @code{libf2c} library, +used by @code{g77}, handles only double-precision values. + +Since @samp{0.2} in the program is a single-precision value, it +is converted to double precision (still in binary notation) +before being converted back to decimal. +The conversion to binary appends _binary_ zero digits to the +original value---which, again, is an inexact approximation of +0.2---resulting in an approximation that is much less exact +than is connoted by the use of double precision. + +(The appending of binary zero digits has essentially the same +effect as taking a particular decimal approximation of +@samp{1/3}, such as @samp{0.3333333}, and appending decimal +zeros to it, producing @samp{0.33333330000000000}. +Treating the resulting decimal approximation as if it really +had 18 or so digits of valid precision would make it seem +a very poor approximation of @samp{1/3}.) + +As a result of converting the single-precision approximation +to double precision by appending binary zeros, the conversion +of the resulting double-precision +value to decimal produces what looks like an incorrect +result, when in fact the result is @emph{inexact}, and +is probably no less inaccurate or imprecise an approximation +of 0.2 than is produced by other compilers that happen to output +the converted value as ``exactly'' @samp{0.2}. +(Some compilers behave in a way that can make them appear +to retain more accuracy across a conversion of a single-precision +constant to double precision. +@xref{Context-Sensitive Constants}, to see why +this practice is illusory and even dangerous.) + +Note that a more exact approximation of the constant is +computed when the program is changed to specify a +double-precision constant: + +@smallexample +PRINT *, 0.2D0 +END +@end smallexample + +Future versions of @code{g77} and/or @code{libf2c} might convert +single-precision values directly to decimal, +instead of converting them to double precision first. +This would tend to result in output that is more consistent +with that produced by some other Fortran implementations. + +@include bugs.texi + +@node Missing Features +@section Missing Features + +This section lists features we know are missing from @code{g77}, +and which we want to add someday. +(There is no priority implied in the ordering below.) + +@menu +GNU Fortran language: +* Better Source Model:: +* Fortran 90 Support:: +* Intrinsics in PARAMETER Statements:: +* SELECT CASE on CHARACTER Type:: +* RECURSIVE Keyword:: +* Popular Non-standard Types:: +* Full Support for Compiler Types:: +* Array Bounds Expressions:: +* POINTER Statements:: +* Sensible Non-standard Constructs:: +* FLUSH Statement:: +* Expressions in FORMAT Statements:: +* Explicit Assembler Code:: +* Q Edit Descriptor:: + +GNU Fortran dialects: +* Old-style PARAMETER Statements:: +* TYPE and ACCEPT I/O Statements:: +* STRUCTURE UNION RECORD MAP:: +* OPEN CLOSE and INQUIRE Keywords:: +* ENCODE and DECODE:: +* Suppressing Space Padding:: +* Fortran Preprocessor:: +* Bit Operations on Floating-point Data:: + +New facilities: +* POSIX Standard:: +* Floating-point Exception Handling:: +* Nonportable Conversions:: +* Large Automatic Arrays:: +* Support for Threads:: +* Increasing Precision/Range:: + +Better diagnostics: +* Gracefully Handle Sensible Bad Code:: +* Non-standard Conversions:: +* Non-standard Intrinsics:: +* Modifying DO Variable:: +* Better Pedantic Compilation:: +* Warn About Implicit Conversions:: +* Invalid Use of Hollerith Constant:: +* Dummy Array Without Dimensioning Dummy:: +* Invalid FORMAT Specifiers:: +* Ambiguous Dialects:: +* Unused Labels:: +* Informational Messages:: + +Run-time facilities: +* Uninitialized Variables at Run Time:: +* Bounds Checking at Run Time:: + +Debugging: +* Labels Visible to Debugger:: +@end menu + +@node Better Source Model +@subsection Better Source Model + +@code{g77} needs to provide, as the default source-line model, +a ``pure visual'' mode, where +the interpretation of a source program in this mode can be accurately +determined by a user looking at a traditionally displayed rendition +of the program (assuming the user knows whether the program is fixed +or free form). + +The design should assume the user cannot tell tabs from spaces +and cannot see trailing spaces on lines, but has canonical tab stops +and, for fixed-form source, has the ability to always know exactly +where column 72 is (since the Fortran standard itself requires +this for fixed-form source). + +This would change the default treatment of fixed-form source +to not treat lines with tabs as if they were infinitely long---instead, +they would end at column 72 just as if the tabs were replaced +by spaces in the canonical way. + +As part of this, provide common alternate models (Digital, @code{f2c}, +and so on) via command-line options. +This includes allowing arbitrarily long +lines for free-form source as well as fixed-form source and providing +various limits and diagnostics as appropriate. + +@cindex sequence numbers +@cindex columns 73 through 80 +Also, @code{g77} should offer, perhaps even default to, warnings +when characters beyond the last valid column are anything other +than spaces. +This would mean code with ``sequence numbers'' in columns 73 through 80 +would be rejected, and there's a lot of that kind of code around, +but one of the most frequent bugs encountered by new users is +accidentally writing fixed-form source code into and beyond +column 73. +So, maybe the users of old code would be able to more easily handle +having to specify, say, a @code{-Wno-col73to80} option. + +@node Fortran 90 Support +@subsection Fortran 90 Support +@cindex Fortran 90 support +@cindex support, Fortran 90 + +@code{g77} does not support many of the features that +distinguish Fortran 90 (and, now, Fortran 95) from +ANSI FORTRAN 77. + +Some Fortran 90 features are supported, because they +make sense to offer even to die-hard users of F77. +For example, many of them codify various ways F77 has +been extended to meet users' needs during its tenure, +so @code{g77} might as well offer them as the primary +way to meet those same needs, even if it offers compatibility +with one or more of the ways those needs were met +by other F77 compilers in the industry. + +Still, many important F90 features are not supported, +because no attempt has been made to research each and +every feature and assess its viability in @code{g77}. +In the meantime, users who need those features must +use Fortran 90 compilers anyway, and the best approach +to adding some F90 features to GNU Fortran might well be +to fund a comprehensive project to create GNU Fortran 95. + +@node Intrinsics in PARAMETER Statements +@subsection Intrinsics in @code{PARAMETER} Statements +@cindex PARAMETER statement +@cindex statements, PARAMETER + +@code{g77} doesn't allow intrinsics in @code{PARAMETER} statements. +This feature is considered to be absolutely vital, even though it +is not standard-conforming, and is scheduled for version 0.6. + +Related to this, @code{g77} doesn't allow non-integral +exponentiation in @code{PARAMETER} statements, such as +@samp{PARAMETER (R=2**.25)}. +It is unlikely @code{g77} will ever support this feature, +as doing it properly requires complete emulation of +a target computer's floating-point facilities when +building @code{g77} as a cross-compiler. +But, if the @code{gcc} back end is enhanced to provide +such a facility, @code{g77} will likely use that facility +in implementing this feature soon afterwards. + +@node SELECT CASE on CHARACTER Type +@subsection @code{SELECT CASE} on @code{CHARACTER} Type + +Character-type selector/cases for @code{SELECT CASE} currently +are not supported. + +@node RECURSIVE Keyword +@subsection @code{RECURSIVE} Keyword +@cindex RECURSIVE keyword +@cindex keywords, RECURSIVE +@cindex recursion, lack of +@cindex lack of recursion + +@code{g77} doesn't support the @code{RECURSIVE} keyword that +F90 compilers do. +Nor does it provide any means for compiling procedures +designed to do recursion. + +All recursive code can be rewritten to not use recursion, +but the result is not pretty. + +@node Increasing Precision/Range +@subsection Increasing Precision/Range +@cindex -r8 +@cindex -i8 +@cindex f2c +@cindex increasing precision +@cindex precision, increasing +@cindex increasing range +@cindex range, increasing +@cindex Toolpack +@cindex Netlib + +Some compilers, such as @code{f2c}, have an option (@samp{-r8} or +similar) that provides automatic treatment of @code{REAL} +entities such that they have twice the storage size, and +a corresponding increase in the range and precision, of what +would normally be the @code{REAL(KIND=1)} (default @code{REAL}) type. +(This affects @code{COMPLEX} the same way.) + +They also typically offer another option (@samp{-i8}) to increase +@code{INTEGER} entities so they are twice as large +(with roughly twice as much range). + +(There are potential pitfalls in using these options.) + +@code{g77} does not yet offer any option that performs these +kinds of transformations. +Part of the problem is the lack of detailed specifications regarding +exactly how these options affect the interpretation of constants, +intrinsics, and so on. + +Until @code{g77} addresses this need, programmers could improve +the portability of their code by modifying it to not require +compile-time options to produce correct results. +Some free tools are available which may help, specifically +in Toolpack (which one would expect to be sound) and the @file{fortran} +section of the Netlib repository. + +Use of preprocessors can provide a fairly portable means +to work around the lack of widely portable methods in the Fortran +language itself (though increasing acceptance of Fortran 90 would +alleviate this problem). + +@node Popular Non-standard Types +@subsection Popular Non-standard Types +@cindex INTEGER*2 support +@cindex LOGICAL*1 support + +@code{g77} doesn't fully support @code{INTEGER*2}, @code{LOGICAL*1}, +and similar. +Version 0.6 will provide full support for this very +popular set of features. +In the meantime, version 0.5.18 provides rudimentary support +for them. + +@node Full Support for Compiler Types +@subsection Full Support for Compiler Types + +@cindex REAL*16 support +@code{g77} doesn't support @code{INTEGER}, @code{REAL}, and @code{COMPLEX} equivalents +for @emph{all} applicable back-end-supported types (@code{char}, @code{short int}, +@code{int}, @code{long int}, @code{long long int}, and @code{long double}). +This means providing intrinsic support, and maybe constant +support (using F90 syntax) as well, and, for most +machines will result in automatic support of @code{INTEGER*1}, +@code{INTEGER*2}, @code{INTEGER*8}, maybe even @code{REAL*16}, +and so on. +This is scheduled for version 0.6. + +@node Array Bounds Expressions +@subsection Array Bounds Expressions +@cindex array elements, in adjustable array bounds +@cindex function references, in adjustable array bounds +@cindex array bounds, adjustable +@cindex DIMENSION statement +@cindex statements, DIMENSION + +@code{g77} doesn't support more general expressions to dimension +arrays, such as array element references, function +references, etc. + +For example, @code{g77} currently does not accept the following: + +@smallexample +SUBROUTINE X(M, N) +INTEGER N(10), M(N(2), N(1)) +@end smallexample + +@node POINTER Statements +@subsection POINTER Statements +@cindex POINTER statement +@cindex statements, POINTER +@cindex Cray pointers + +@code{g77} doesn't support pointers or allocatable objects +(other than automatic arrays). +This set of features is +probably considered just behind intrinsics +in @code{PARAMETER} statements on the list of large, +important things to add to @code{g77}. + +@node Sensible Non-standard Constructs +@subsection Sensible Non-standard Constructs + +@code{g77} rejects things other compilers accept, +like @samp{INTRINSIC SQRT,SQRT}. +As time permits in the future, some of these things that are easy for +humans to read and write and unlikely to be intended to mean something +else will be accepted by @code{g77} (though @samp{-fpedantic} should +trigger warnings about such non-standard constructs). + +Until @code{g77} no longer gratuitously rejects sensible code, +you might as well fix your code +to be more standard-conforming and portable. + +The kind of case that is important to except from the +recommendation to change your code is one where following +good coding rules would force you to write non-standard +code that nevertheless has a clear meaning. + +For example, when writing an @code{INCLUDE} file that +defines a common block, it might be appropriate to +include a @code{SAVE} statement for the common block +(such as @samp{SAVE /CBLOCK/}), so that variables +defined in the common block retain their values even +when all procedures declaring the common block become +inactive (return to their callers). + +However, putting @code{SAVE} statements in an @code{INCLUDE} +file would prevent otherwise standard-conforming code +from also specifying the @code{SAVE} statement, by itself, +to indicate that all local variables and arrays are to +have the @code{SAVE} attribute. + +For this reason, @code{g77} already has been changed to +allow this combination, because although the general +problem of gratuitously rejecting unambiguous and +``safe'' constructs still exists in @code{g77}, this +particular construct was deemed useful enough that +it was worth fixing @code{g77} for just this case. + +So, while there is no need to change your code +to avoid using this particular construct, there +might be other, equally appropriate but non-standard +constructs, that you shouldn't have to stop using +just because @code{g77} (or any other compiler) +gratuitously rejects it. + +Until the general problem is solved, if you have +any such construct you believe is worthwhile +using (e.g. not just an arbitrary, redundant +specification of an attribute), please submit a +bug report with an explanation, so we can consider +fixing @code{g77} just for cases like yours. + +@node FLUSH Statement +@subsection @code{FLUSH} Statement + +@code{g77} could perhaps use a @code{FLUSH} statement that +does what @samp{CALL FLUSH} does, +but that supports @samp{*} as the unit designator (same unit as for +@code{PRINT}) and accepts @code{ERR=} and/or @code{IOSTAT=} +specifiers. + +@node Expressions in FORMAT Statements +@subsection Expressions in @code{FORMAT} Statements +@cindex FORMAT statement +@cindex statements, FORMAT + +@code{g77} doesn't support @samp{FORMAT(I)} and the like. +Supporting this requires a significant redesign or replacement +of @code{libf2c}. + +However, a future version of @code{g77} might support +this construct when the expression is constant. For +example: + +@smallexample + PARAMETER (IWIDTH = 12) +10 FORMAT (I) +@end smallexample + +In the meantime, at least for output (@code{PRINT} and +@code{WRITE}), Fortran code making use of this feature can +be rewritten to avoid it by constructing the @code{FORMAT} +string in a @code{CHARACTER} variable or array, then +using that variable or array in place of the @code{FORMAT} +statement label to do the original @code{PRINT} or @code{WRITE}. + +Many uses of this feature on input can be rewritten this way +as well, but not all can. +For example, this can be rewritten: + +@smallexample + READ 20, I +20 FORMAT (I) +@end smallexample + +However, this cannot, in general, be rewritten, especially +when @code{ERR=} and @code{END=} constructs are employed: + +@smallexample + READ 30, J, I +30 FORMAT (I) +@end smallexample + +@node Explicit Assembler Code +@subsection Explicit Assembler Code + +@code{g77} needs to provide some way, a la @code{gcc}, for @code{g77} +code to specify explicit assembler code. + +@node Q Edit Descriptor +@subsection Q Edit Descriptor +@cindex FORMAT statement +@cindex Q edit descriptor + +The @code{Q} edit descriptor in @code{FORMAT}s isn't supported. +(This is meant to get the number of characters remaining in an input record.) +Supporting this requires a significant redesign or replacement +of @code{libf2c}. + +A workaround might be using internal I/O or the stream-based intrinsics. +@xref{FGetC Intrinsic (subroutine)}. + +@node Old-style PARAMETER Statements +@subsection Old-style PARAMETER Statements +@cindex PARAMETER statement +@cindex statements, PARAMETER + +@code{g77} doesn't accept @samp{PARAMETER I=1}. +Supporting this obsolete form of +the @code{PARAMETER} statement would not be particularly hard, as most of the +parsing code is already in place and working. + +Until time/money is +spent implementing it, you might as well fix your code to use the +standard form, @samp{PARAMETER (I=1)} (possibly needing +@samp{INTEGER I} preceding the @code{PARAMETER} statement as well, +otherwise, in the obsolete form of @code{PARAMETER}, the +type of the variable is set from the type of the constant being +assigned to it). + +@node TYPE and ACCEPT I/O Statements +@subsection @code{TYPE} and @code{ACCEPT} I/O Statements +@cindex TYPE statement +@cindex statements, TYPE +@cindex ACCEPT statement +@cindex statements, ACCEPT + +@code{g77} doesn't support the I/O statements @code{TYPE} and +@code{ACCEPT}. +These are common extensions that should be easy to support, +but also are fairly easy to work around in user code. + +Generally, any @samp{TYPE fmt,list} I/O statement can be replaced +by @samp{PRINT fmt,list}. +And, any @samp{ACCEPT fmt,list} statement can be +replaced by @samp{READ fmt,list}. + +@node STRUCTURE UNION RECORD MAP +@subsection @code{STRUCTURE}, @code{UNION}, @code{RECORD}, @code{MAP} +@cindex STRUCTURE statement +@cindex statements, STRUCTURE +@cindex UNION statement +@cindex statements, UNION +@cindex RECORD statement +@cindex statements, RECORD +@cindex MAP statement +@cindex statements, MAP + +@code{g77} doesn't support @code{STRUCTURE}, @code{UNION}, @code{RECORD}, +@code{MAP}. +This set of extensions is quite a bit +lower on the list of large, important things to add to @code{g77}, partly +because it requires a great deal of work either upgrading or +replacing @code{libf2c}. + +@node OPEN CLOSE and INQUIRE Keywords +@subsection @code{OPEN}, @code{CLOSE}, and @code{INQUIRE} Keywords +@cindex disposition of files +@cindex OPEN statement +@cindex statements, OPEN +@cindex CLOSE statement +@cindex statements, CLOSE +@cindex INQUIRE statement +@cindex statements, INQUIRE + +@code{g77} doesn't have support for keywords such as @code{DISP='DELETE'} in +the @code{OPEN}, @code{CLOSE}, and @code{INQUIRE} statements. +These extensions are easy to add to @code{g77} itself, but +require much more work on @code{libf2c}. + +@node ENCODE and DECODE +@subsection @code{ENCODE} and @code{DECODE} +@cindex ENCODE statement +@cindex statements, ENCODE +@cindex DECODE statement +@cindex statements, DECODE + +@code{g77} doesn't support @code{ENCODE} or @code{DECODE}. + +These statements are best replaced by READ and WRITE statements +involving internal files (CHARACTER variables and arrays). + +For example, replace a code fragment like + +@smallexample + INTEGER*1 LINE(80) +@dots{} + DECODE (80, 9000, LINE) A, B, C +@dots{} +9000 FORMAT (1X, 3(F10.5)) +@end smallexample + +@noindent +with: + +@smallexample + CHARACTER*80 LINE +@dots{} + READ (UNIT=LINE, FMT=9000) A, B, C +@dots{} +9000 FORMAT (1X, 3(F10.5)) +@end smallexample + +Similarly, replace a code fragment like + +@smallexample + INTEGER*1 LINE(80) +@dots{} + ENCODE (80, 9000, LINE) A, B, C +@dots{} +9000 FORMAT (1X, 'OUTPUT IS ', 3(F10.5)) +@end smallexample + +@noindent +with: + +@smallexample + CHARACTER*80 LINE +@dots{} + WRITE (UNIT=LINE, FMT=9000) A, B, C +@dots{} +9000 FORMAT (1X, 'OUTPUT IS ', 3(F10.5)) +@end smallexample + +It is entirely possible that @code{ENCODE} and @code{DECODE} will +be supported by a future version of @code{g77}. + +@node Suppressing Space Padding +@subsection Suppressing Space Padding of Source Lines + +@code{g77} should offer VXT-Fortran-style suppression of virtual +spaces at the end of a source line +if an appropriate command-line option is specified. + +This affects cases where +a character constant is continued onto the next line in a fixed-form +source file, as in the following example: + +@smallexample +10 PRINT *,'HOW MANY + 1 SPACES?' +@end smallexample + +@noindent +@code{g77}, and many other compilers, virtually extend +the continued line through column 72 with spaces that become part +of the character constant, but Digital Fortran normally didn't, +leaving only one space between @samp{MANY} and @samp{SPACES?} +in the output of the above statement. + +Fairly recently, at least one version of Digital Fortran +was enhanced to provide the other behavior when a +command-line option is specified, apparently due to demand +from readers of the USENET group @file{comp.lang.fortran} +to offer conformance to this widespread practice in the +industry. +@code{g77} should return the favor by offering conformance +to Digital's approach to handling the above example. + +@node Fortran Preprocessor +@subsection Fortran Preprocessor + +@code{g77} should offer a preprocessor designed specifically +for Fortran to replace @samp{cpp -traditional}. +There are several out there worth evaluating, at least. + +Such a preprocessor would recognize Hollerith constants, +properly parse comments and character constants, and so on. +It might also recognize, process, and thus preprocess +files included via the @code{INCLUDE} directive. + +@node Bit Operations on Floating-point Data +@subsection Bit Operations on Floating-point Data +@cindex AND intrinsic +@cindex intrinsics, AND +@cindex OR intrinsic +@cindex intrinsics, OR +@cindex SHIFT intrinsic +@cindex intrinsics, SHIFT + +@code{g77} does not allow @code{REAL} and other non-integral types for +arguments to intrinsics like @code{AND}, @code{OR}, and @code{SHIFT}. + +For example, this program is rejected by @code{g77}, because +the intrinsic @code{IAND} does not accept @code{REAL} arguments: + +@smallexample +DATA A/7.54/, B/9.112/ +PRINT *, IAND(A, B) +END +@end smallexample + +@node POSIX Standard +@subsection @code{POSIX} Standard + +@code{g77} should support the POSIX standard for Fortran. + +@node Floating-point Exception Handling +@subsection Floating-point Exception Handling +@cindex floating point exceptions +@cindex exceptions, floating point +@cindex FPE handling +@cindex NaN values + +The @code{gcc} backend and, consequently, @code{g77}, currently provides no +control over whether or not floating-point exceptions are trapped or +ignored. +(Ignoring them typically results in NaN values being +propagated in systems that conform to IEEE 754.)@ +The behaviour is inherited from the system-dependent startup code. + +Most systems provide some C-callable mechanism to change this; this can +be invoked at startup using @code{gcc}'s @code{constructor} attribute. +For example, just compiling and linking the following C code with your +program will turn on exception trapping for the ``common'' exceptions +on an x86-based GNU system: + +@smallexample +#include +void __attribute__ ((constructor)) +trapfpe () @{ + (void) __setfpucw (_FPU_DEFAULT & + ~(_FPU_MASK_IM | _FPU_MASK_ZM | _FPU_MASK_OM)); +@} +@end smallexample + +@node Nonportable Conversions +@subsection Nonportable Conversions +@cindex nonportable conversions +@cindex conversions, nonportable + +@code{g77} doesn't accept some particularly nonportable, +silent data-type conversions such as @code{LOGICAL} +to @code{REAL} (as in @samp{A=.FALSE.}, where @samp{A} +is type @code{REAL}), that other compilers might +quietly accept. + +Some of these conversions are accepted by @code{g77} +when the @samp{-fugly} option is specified. +Perhaps it should accept more or all of them. + +@node Large Automatic Arrays +@subsection Large Automatic Arrays +@cindex automatic arrays +@cindex arrays, automatic + +Currently, automatic arrays always are allocated on the stack. +For situations where the stack cannot be made large enough, +@code{g77} should offer a compiler option that specifies +allocation of automatic arrays in heap storage. + +@node Support for Threads +@subsection Support for Threads +@cindex threads +@cindex parallel processing + +Neither the code produced by @code{g77} nor the @code{libf2c} library +are thread-safe, nor does @code{g77} have support for parallel processing +(other than the instruction-level parallelism available on some +processors). +A package such as PVM might help here. + +@node Gracefully Handle Sensible Bad Code +@subsection Gracefully Handle Sensible Bad Code + +@code{g77} generally should continue processing for +warnings and recoverable (user) errors whenever possible---that +is, it shouldn't gratuitously make bad or useless code. + +For example: + +@smallexample +INTRINSIC ZABS +CALL FOO(ZABS) +END +@end smallexample + +@noindent +When compiling the above with @samp{-ff2c-intrinsics-disable}, +@code{g77} should indeed complain about passing @code{ZABS}, +but it still should compile, instead of rejecting +the entire @code{CALL} statement. +(Some of this is related to improving +the compiler internals to improve how statements are analyzed.) + +@node Non-standard Conversions +@subsection Non-standard Conversions + +@samp{-Wconversion} and related should flag places where non-standard +conversions are found. +Perhaps much of this would be part of @samp{-Wugly*}. + +@node Non-standard Intrinsics +@subsection Non-standard Intrinsics + +@code{g77} needs a new option, like @samp{-Wintrinsics}, to warn about use of +non-standard intrinsics without explicit @code{INTRINSIC} statements for them. +This would help find code that might fail silently when ported to another +compiler. + +@node Modifying DO Variable +@subsection Modifying @code{DO} Variable + +@code{g77} should warn about modifying @code{DO} variables +via @code{EQUIVALENCE}. +(The internal information gathered to produce this warning +might also be useful in setting the +internal ``doiter'' flag for a variable or even array +reference within a loop, since that might produce faster code someday.) + +For example, this code is invalid, so @code{g77} should warn about +the invalid assignment to @samp{NOTHER}: + +@smallexample +EQUIVALENCE (I, NOTHER) +DO I = 1, 100 + IF (I.EQ. 10) NOTHER = 20 +END DO +@end smallexample + +@node Better Pedantic Compilation +@subsection Better Pedantic Compilation + +@code{g77} needs to support @samp{-fpedantic} more thoroughly, +and use it only to generate +warnings instead of rejecting constructs outright. +Have it warn: +if a variable that dimensions an array is not a dummy or placed +explicitly in @code{COMMON} (F77 does not allow it to be +placed in @code{COMMON} via @code{EQUIVALENCE}); if specification statements +follow statement-function-definition statements; about all sorts of +syntactic extensions. + +@node Warn About Implicit Conversions +@subsection Warn About Implicit Conversions + +@code{g77} needs a @samp{-Wpromotions} option to warn if source code appears +to expect automatic, silent, and +somewhat dangerous compiler-assisted conversion of @code{REAL(KIND=1)} +constants to @code{REAL(KIND=2)} based on context. + +For example, it would warn about cases like this: + +@smallexample +DOUBLE PRECISION FOO +PARAMETER (TZPHI = 9.435784839284958) +FOO = TZPHI * 3D0 +@end smallexample + +@node Invalid Use of Hollerith Constant +@subsection Invalid Use of Hollerith Constant + +@code{g77} should disallow statements like @samp{RETURN 2HAB}, +which are invalid in both source forms +(unlike @samp{RETURN (2HAB)}, +which probably still makes no sense but at least can +be reliably parsed). +Fixed-form processing rejects it, but not free-form, except +in a way that is a bit difficult to understand. + +@node Dummy Array Without Dimensioning Dummy +@subsection Dummy Array Without Dimensioning Dummy + +@code{g77} should complain when a list of dummy arguments containing an +adjustable dummy array does +not also contain every variable listed in the dimension list of the +adjustable array. + +Currently, @code{g77} does complain about a variable that +dimensions an array but doesn't appear in any dummy list or @code{COMMON} +area, but this needs to be extended to catch cases where it doesn't appear in +every dummy list that also lists any arrays it dimensions. + +For example, @code{g77} should warn about the entry point @samp{ALT} +below, since it includes @samp{ARRAY} but not @samp{ISIZE} in its +list of arguments: + +@smallexample +SUBROUTINE PRIMARY(ARRAY, ISIZE) +REAL ARRAY(ISIZE) +ENTRY ALT(ARRAY) +@end smallexample + +@node Invalid FORMAT Specifiers +@subsection Invalid FORMAT Specifiers + +@code{g77} should check @code{FORMAT} specifiers for validity +as it does @code{FORMAT} statements. + +For example, a diagnostic would be produced for: + +@smallexample +PRINT 'HI THERE!' !User meant PRINT *, 'HI THERE!' +@end smallexample + +@node Ambiguous Dialects +@subsection Ambiguous Dialects + +@code{g77} needs a set of options such as @samp{-Wugly*}, @samp{-Wautomatic}, +@samp{-Wvxt}, @samp{-Wf90}, and so on. +These would warn about places in the user's source where ambiguities +are found, helpful in resolving ambiguities in the program's +dialect or dialects. + +@node Unused Labels +@subsection Unused Labels + +@code{g77} should warn about unused labels when @samp{-Wunused} is in effect. + +@node Informational Messages +@subsection Informational Messages + +@code{g77} needs an option to suppress information messages (notes). +@samp{-w} does this but also suppresses warnings. +The default should be to suppress info messages. + +Perhaps info messages should simply be eliminated. + +@node Uninitialized Variables at Run Time +@subsection Uninitialized Variables at Run Time + +@code{g77} needs an option to initialize everything (not otherwise +explicitly initialized) to ``weird'' +(machine-dependent) values, e.g. NaNs, bad (non-@code{NULL}) pointers, and +largest-magnitude integers, would help track down references to +some kinds of uninitialized variables at run time. + +Note that use of the options @samp{-O -Wuninitialized} can catch +many such bugs at compile time. + +@node Bounds Checking at Run Time +@subsection Bounds Checking at Run Time + +@code{g77} should offer run-time bounds-checking of array/subscript references +in a fashion similar to @code{f2c}. + +Note that @code{g77} already warns about references to out-of-bounds +elements of arrays when it detects these at compile time. + +@node Labels Visible to Debugger +@subsection Labels Visible to Debugger + +@code{g77} should output debugging information for statements labels, +for use by debuggers that know how to support them. +Same with weirder things like construct names. +It is not yet known if any debug formats or debuggers support these. + +@node Disappointments +@section Disappointments and Misunderstandings + +These problems are perhaps regrettable, but we don't know any practical +way around them for now. + +@menu +* Mangling of Names:: @samp{SUBROUTINE FOO} is given + external name @samp{foo_}. +* Multiple Definitions of External Names:: No doing both @samp{COMMON /FOO/} + and @samp{SUBROUTINE FOO}. +* Limitation on Implicit Declarations:: No @samp{IMPLICIT CHARACTER*(*)}. +@end menu + +@node Mangling of Names +@subsection Mangling of Names in Source Code +@cindex naming issues +@cindex external names +@cindex common blocks +@cindex name space +@cindex underscores + +The current external-interface design, which includes naming of +external procedures, COMMON blocks, and the library interface, +has various usability problems, including things like adding +underscores where not really necessary (and preventing easier +inter-language operability) and yet not providing complete +namespace freedom for user C code linked with Fortran apps (due +to the naming of functions in the library, among other things). + +Project GNU should at least get all this ``right'' for systems +it fully controls, such as the Hurd, and provide defaults and +options for compatibility with existing systems and interoperability +with popular existing compilers. + +@node Multiple Definitions of External Names +@subsection Multiple Definitions of External Names +@cindex block data +@cindex BLOCK DATA statement +@cindex statements, BLOCK DATA +@cindex COMMON statement +@cindex statements, COMMON +@cindex naming conflicts + +@code{g77} doesn't allow a common block and an external procedure or +@code{BLOCK DATA} to have the same name. +Some systems allow this, but @code{g77} does not, +to be compatible with @code{f2c}. + +@code{g77} could special-case the way it handles +@code{BLOCK DATA}, since it is not compatible with @code{f2c} in this +particular area (necessarily, since @code{g77} offers an +important feature here), but +it is likely that such special-casing would be very annoying to people +with programs that use @samp{EXTERNAL FOO}, with no other mention of +@samp{FOO} in the same program unit, to refer to external procedures, since +the result would be that @code{g77} would treat these references as requests to +force-load BLOCK DATA program units. + +In that case, if @code{g77} modified +names of @code{BLOCK DATA} so they could have the same names as +@code{COMMON}, users +would find that their programs wouldn't link because the @samp{FOO} procedure +didn't have its name translated the same way. + +(Strictly speaking, +@code{g77} could emit a null-but-externally-satisfying definition of +@samp{FOO} with its name transformed as if it had been a +@code{BLOCK DATA}, but that probably invites more trouble than it's +worth.) + +@node Limitation on Implicit Declarations +@subsection Limitation on Implicit Declarations +@cindex IMPLICIT CHARACTER*(*) statement +@cindex statements, IMPLICIT CHARACTER*(*) + +@code{g77} disallows @code{IMPLICIT CHARACTER*(*)}. +This is not standard-conforming. + +@node Non-bugs +@section Certain Changes We Don't Want to Make + +This section lists changes that people frequently request, but which +we do not make because we think GNU Fortran is better without them. + +@menu +* Backslash in Constants:: Why @samp{'\\'} is a constant that + is one, not two, characters long. +* Initializing Before Specifying:: Why @samp{DATA VAR/1/} can't precede + @samp{COMMON VAR}. +* Context-Sensitive Intrinsicness:: Why @samp{CALL SQRT} won't work. +* Context-Sensitive Constants:: Why @samp{9.435784839284958} is a + single-precision constant, + and might be interpreted as + @samp{9.435785} or similar. +* Equivalence Versus Equality:: Why @samp{.TRUE. .EQ. .TRUE.} won't work. +* Order of Side Effects:: Why @samp{J = IFUNC() - IFUNC()} might + not behave as expected. +@end menu + +@node Backslash in Constants +@subsection Backslash in Constants +@cindex backslash +@cindex f77 support +@cindex support, f77 + +In the opinion of many experienced Fortran users, +@samp{-fno-backslash} should be the default, not @samp{-fbackslash}, +as currently set by @code{g77}. + +First of all, you can always specify +@samp{-fno-backslash} to turn off this processing. + +Despite not being within the spirit (though apparently within the +letter) of the ANSI FORTRAN 77 standard, @code{g77} defaults to +@samp{-fbackslash} because that is what most UNIX @code{f77} commands +default to, and apparently lots of code depends on this feature. + +This is a particularly troubling issue. +The use of a C construct in the midst of Fortran code +is bad enough, worse when it makes existing Fortran +programs stop working (as happens when programs written +for non-UNIX systems are ported to UNIX systems with +compilers that provide the @samp{-fbackslash} feature +as the default---sometimes with no option to turn it off). + +The author of GNU Fortran wished, for reasons of linguistic +purity, to make @samp{-fno-backslash} the default for GNU +Fortran and thus require users of UNIX @code{f77} and @code{f2c} +to specify @samp{-fbackslash} to get the UNIX behavior. + +However, the realization that @code{g77} is intended as +a replacement for @emph{UNIX} @code{f77}, caused the author +to choose to make @code{g77} as compatible with +@code{f77} as feasible, which meant making @samp{-fbackslash} +the default. + +The primary focus on compatibility is at the source-code +level, and the question became ``What will users expect +a replacement for @code{f77} to do, by default?'' +Although at least one UNIX @code{f77} does not provide +@samp{-fbackslash} as a default, it appears that +the majority of them do, which suggests that +the majority of code that is compiled by UNIX @code{f77} +compilers expects @samp{-fbackslash} to be the default. + +It is probably the case that more code exists +that would @emph{not} work with @samp{-fbackslash} +in force than code that requires it be in force. + +However, most of @emph{that} code is not being compiled +with @code{f77}, +and when it is, new build procedures (shell scripts, +makefiles, and so on) must be set up anyway so that +they work under UNIX. +That makes a much more natural and safe opportunity for +non-UNIX users to adapt their build procedures for +@code{g77}'s default of @samp{-fbackslash} than would +exist for the majority of UNIX @code{f77} users who +would have to modify existing, working build procedures +to explicitly specify @samp{-fbackslash} if that was +not the default. + +One suggestion has been to configure the default for +@samp{-fbackslash} (and perhaps other options as well) +based on the configuration of @code{g77}. + +This is technically quite straightforward, but will be avoided +even in cases where not configuring defaults to be +dependent on a particular configuration greatly inconveniences +some users of legacy code. + +Many users appreciate the GNU compilers because they provide an +environment that is uniform across machines. +These users would be +inconvenienced if the compiler treated things like the +format of the source code differently on certain machines. + +Occasionally users write programs intended only for a particular machine +type. +On these occasions, the users would benefit if the GNU Fortran compiler +were to support by default the same dialect as the other compilers on +that machine. +But such applications are rare. +And users writing a +program to run on more than one type of machine cannot possibly benefit +from this kind of compatibility. +(This is consistent with the design goals for @code{gcc}. +To change them for @code{g77}, you must first change them +for @code{gcc}. +Do not ask the maintainers of @code{g77} to do this for you, +or to disassociate @code{g77} from the widely understood, if +not widely agreed-upon, goals for GNU compilers in general.) + +This is why GNU Fortran does and will treat backslashes in the same +fashion on all types of machines (by default). +@xref{Direction of Language Development}, for more information on +this overall philosophy guiding the development of the GNU Fortran +language. + +Of course, users strongly concerned about portability should indicate +explicitly in their build procedures which options are expected +by their source code, or write source code that has as few such +expectations as possible. + +For example, avoid writing code that depends on backslash (@samp{\}) +being interpreted either way in particular, such as by +starting a program unit with: + +@smallexample +CHARACTER BACKSL +PARAMETER (BACKSL = '\\') +@end smallexample + +@noindent +Then, use concatenation of @samp{BACKSL} anyplace a backslash +is desired. +In this way, users can write programs which have the same meaning +in many Fortran dialects. + +(However, this technique does not work for Hollerith constants---which +is just as well, since the only generally portable uses for Hollerith +constants are in places where character constants can and should +be used instead, for readability.) + +@node Initializing Before Specifying +@subsection Initializing Before Specifying +@cindex initialization, statement placement +@cindex placing initialization statements + +@code{g77} does not allow @samp{DATA VAR/1/} to appear in the +source code before @samp{COMMON VAR}, +@samp{DIMENSION VAR(10)}, @samp{INTEGER VAR}, and so on. +In general, @code{g77} requires initialization of a variable +or array to be specified @emph{after} all other specifications +of attributes (type, size, placement, and so on) of that variable +or array are specified (though @emph{confirmation} of data type is +permitted). + +It is @emph{possible} @code{g77} will someday allow all of this, +even though it is not allowed by the FORTRAN 77 standard. + +Then again, maybe it is better to have +@code{g77} always require placement of @code{DATA} +so that it can possibly immediately write constants +to the output file, thus saving time and space. + +That is, @samp{DATA A/1000000*1/} should perhaps always +be immediately writable to canonical assembler, unless it's already known +to be in a @code{COMMON} area following as-yet-uninitialized stuff, +and to do this it cannot be followed by @samp{COMMON A}. + +@node Context-Sensitive Intrinsicness +@subsection Context-Sensitive Intrinsicness +@cindex intrinsics, context-sensitive +@cindex context-sensitive intrinsics + +@code{g77} treats procedure references to @emph{possible} intrinsic +names as always enabling their intrinsic nature, regardless of +whether the @emph{form} of the reference is valid for that +intrinsic. + +For example, @samp{CALL SQRT} is interpreted by @code{g77} as +an invalid reference to the @code{SQRT} intrinsic function, +because the reference is a subroutine invocation. + +First, @code{g77} recognizes the statement @samp{CALL SQRT} +as a reference to a @emph{procedure} named @samp{SQRT}, not +to a @emph{variable} with that name (as it would for a statement +such as @samp{V = SQRT}). + +Next, @code{g77} establishes that, in the program unit being compiled, +@code{SQRT} is an intrinsic---not a subroutine that +happens to have the same name as an intrinsic (as would be +the case if, for example, @samp{EXTERNAL SQRT} was present). + +Finally, @code{g77} recognizes that the @emph{form} of the +reference is invalid for that particular intrinsic. +That is, it recognizes that it is invalid for an intrinsic +@emph{function}, such as @code{SQRT}, to be invoked as +a @emph{subroutine}. + +At that point, @code{g77} issues a diagnostic. + +Some users claim that it is ``obvious'' that @samp{CALL SQRT} +references an external subroutine of their own, not an +intrinsic function. + +However, @code{g77} knows about intrinsic +subroutines, not just functions, and is able to support both having +the same names, for example. + +As a result of this, @code{g77} rejects calls +to intrinsics that are not subroutines, and function invocations +of intrinsics that are not functions, just as it (and most compilers) +rejects invocations of intrinsics with the wrong number (or types) +of arguments. + +So, use the @samp{EXTERNAL SQRT} statement in a program unit that calls +a user-written subroutine named @samp{SQRT}. + +@node Context-Sensitive Constants +@subsection Context-Sensitive Constants +@cindex constants, context-sensitive +@cindex context-sensitive constants + +@code{g77} does not use context to determine the types of +constants or named constants (@code{PARAMETER}), except +for (non-standard) typeless constants such as @samp{'123'O}. + +For example, consider the following statement: + +@smallexample +PRINT *, 9.435784839284958 * 2D0 +@end smallexample + +@noindent +@code{g77} will interpret the (truncated) constant +@samp{9.435784839284958} as a @code{REAL(KIND=1)}, not @code{REAL(KIND=2)}, +constant, because the suffix @code{D0} is not specified. + +As a result, the output of the above statement when +compiled by @code{g77} will appear to have ``less precision'' +than when compiled by other compilers. + +In these and other cases, some compilers detect the +fact that a single-precision constant is used in +a double-precision context and therefore interpret the +single-precision constant as if it was @emph{explicitly} +specified as a double-precision constant. +(This has the effect of appending @emph{decimal}, not +@emph{binary}, zeros to the fractional part of the +number---producing different computational results.) + +The reason this misfeature is dangerous is that a slight, +apparently innocuous change to the source code can change +the computational results. Consider: + +@smallexample +REAL ALMOST, CLOSE +DOUBLE PRECISION FIVE +PARAMETER (ALMOST = 5.000000000001) +FIVE = 5 +CLOSE = 5.000000000001 +PRINT *, 5.000000000001 - FIVE +PRINT *, ALMOST - FIVE +PRINT *, CLOSE - FIVE +END +@end smallexample + +@noindent +Running the above program should +result in the same value being +printed three times. +With @code{g77} as the compiler, +it does. + +However, compiled by many other compilers, +running the above program would print +two or three distinct values, because +in two or three of the statements, the +constant @samp{5.000000000001}, which +on most systems is exactly equal to @samp{5.} +when interpreted as a single-precision constant, +is instead interpreted as a double-precision +constant, preserving the represented +precision. +However, this ``clever'' promotion of +type does not extend to variables or, +in some compilers, to named constants. + +Since programmers often are encouraged to replace manifest +constants or permanently-assigned variables with named +constants (@code{PARAMETER} in Fortran), and might need +to replace some constants with variables having the same +values for pertinent portions of code, +it is important that compilers treat code so modified in the +same way so that the results of such programs are the same. +@code{g77} helps in this regard by treating constants just +the same as variables in terms of determining their types +in a context-independent way. + +Still, there is a lot of existing Fortran code that has +been written to depend on the way other compilers freely +interpret constants' types based on context, so anything +@code{g77} can do to help flag cases of this in such code +could be very helpful. + +@node Equivalence Versus Equality +@subsection Equivalence Versus Equality +@cindex .EQV., with integer operands +@cindex comparing logical expressions +@cindex logical expressions, comparing + +Use of @code{.EQ.} and @code{.NE.} on @code{LOGICAL} operands +is not supported, except via @samp{-fugly}, which is not +recommended except for legacy code (where the behavior expected +by the @emph{code} is assumed). + +Legacy code should be changed, as resources permit, to use @code{.EQV.} +and @code{.NEQV.} instead, as these are permitted by the various +Fortran standards. + +New code should never be written expecting @code{.EQ.} or @code{.NE.} +to work if either of its operands is @code{LOGICAL}. + +The problem with supporting this ``feature'' is that there is +unlikely to be consensus on how it works, as illustrated by the +following sample program: + +@smallexample +LOGICAL L,M,N +DATA L,M,N /3*.FALSE./ +IF (L.AND.M.EQ.N) PRINT *,'L.AND.M.EQ.N' +END +@end smallexample + +The issue raised by the above sample program is: what is the +precedence of @code{.EQ.} (and @code{.NE.}) when applied to +@code{LOGICAL} operands? + +Some programmers will argue that it is the same as the precedence +for @code{.EQ.} when applied to numeric (such as @code{INTEGER}) +operands. +By this interpretation, the subexpression @samp{M.EQ.N} must be +evaluated first in the above program, resulting in a program that, +when run, does not execute the @code{PRINT} statement. + +Other programmers will argue that the precedence is the same as +the precedence for @code{.EQV.}, which is restricted by the standards +to @code{LOGICAL} operands. +By this interpretation, the subexpression @samp{L.AND.M} must be +evaluated first, resulting in a program that @emph{does} execute +the @code{PRINT} statement. + +Assigning arbitrary semantic interpretations to syntactic expressions +that might legitimately have more than one ``obvious'' interpretation +is generally unwise. + +The creators of the various Fortran standards have done a good job +in this case, requiring a distinct set of operators (which have their +own distinct precedence) to compare @code{LOGICAL} operands. +This requirement results in expression syntax with more certain +precedence (without requiring substantial context), making it easier +for programmers to read existing code. +@code{g77} will avoid muddying up elements of the Fortran language +that were well-designed in the first place. + +(Ask C programmers about the precedence of expressions such as +@samp{(a) & (b)} and @samp{(a) - (b)}---they cannot even tell +you, without knowing more context, whether the @samp{&} and @samp{-} +operators are infix (binary) or unary!) + +@node Order of Side Effects +@subsection Order of Side Effects +@cindex side effects, order of evaluation +@cindex order of evaluation, side effects + +@code{g77} does not necessarily produce code that, when run, performs +side effects (such as those performed by function invocations) +in the same order as in some other compiler---or even in the same +order as another version, port, or invocation (using different +command-line options) of @code{g77}. + +It is never safe to depend on the order of evaluation of side effects. +For example, an expression like this may very well behave differently +from one compiler to another: + +@smallexample +J = IFUNC() - IFUNC() +@end smallexample + +@noindent +There is no guarantee that @samp{IFUNC} will be evaluated in any particular +order. +Either invocation might happen first. +If @samp{IFUNC} returns 5 the first time it is invoked, and +returns 12 the second time, @samp{J} might end up with the +value @samp{7}, or it might end up with @samp{-7}. + +Generally, in Fortran, procedures with side-effects intended to +be visible to the caller are best designed as @emph{subroutines}, +not functions. +Examples of such side-effects include: + +@itemize @bullet +@item +The generation of random numbers +that are intended to influence return values. + +@item +Performing I/O +(other than internal I/O to local variables). + +@item +Updating information in common blocks. +@end itemize + +An example of a side-effect that is not intended to be visible +to the caller is a function that maintains a cache of recently +calculated results, intended solely to speed repeated invocations +of the function with identical arguments. +Such a function can be safely used in expressions, because +if the compiler optimizes away one or more calls to the +function, operation of the program is unaffected (aside +from being speeded up). + +@node Warnings and Errors +@section Warning Messages and Error Messages + +@cindex error messages +@cindex warnings vs errors +@cindex messages, warning and error +The GNU compiler can produce two kinds of diagnostics: errors and +warnings. +Each kind has a different purpose: + +@itemize @w{} +@item +@emph{Errors} report problems that make it impossible to compile your +program. +GNU Fortran reports errors with the source file name, line +number, and column within the line where the problem is apparent. + +@item +@emph{Warnings} report other unusual conditions in your code that +@emph{might} indicate a problem, although compilation can (and does) +proceed. +Warning messages also report the source file name, line number, +and column information, +but include the text @samp{warning:} to distinguish them +from error messages. +@end itemize + +Warnings might indicate danger points where you should check to make sure +that your program really does what you intend; or the use of obsolete +features; or the use of nonstandard features of GNU Fortran. +Many warnings are issued only if you ask for them, with one of the +@samp{-W} options (for instance, @samp{-Wall} requests a variety of +useful warnings). + +@emph{Note:} Currently, the text of the line and a pointer to the column +is printed in most @code{g77} diagnostics. +Probably, as of version 0.6, @code{g77} will +no longer print the text of the source line, instead printing +the column number following the file name and line number in +a form that GNU Emacs recognizes. +This change is expected to speed up and reduce the memory usage +of the @code{g77} compiler. +@c +@c Say this when it is true -- hopefully 0.6, maybe 0.7 or later. --burley +@c +@c GNU Fortran always tries to compile your program if possible; it never +@c gratuitously rejects a program whose meaning is clear merely because +@c (for instance) it fails to conform to a standard. In some cases, +@c however, the Fortran standard specifies that certain extensions are +@c forbidden, and a diagnostic @emph{must} be issued by a conforming +@c compiler. The @samp{-pedantic} option tells GNU Fortran to issue warnings +@c in such cases; @samp{-pedantic-errors} says to make them errors instead. +@c This does not mean that @emph{all} non-ANSI constructs get warnings +@c or errors. + +@xref{Warning Options,,Options to Request or Suppress Warnings}, for +more detail on these and related command-line options. + +@node Open Questions +@chapter Open Questions + +Please consider offering useful answers to these questions! + +@itemize @bullet +@item +How do system administrators and users manage multiple incompatible +Fortran compilers on their systems? +How can @code{g77} contribute to this, or at least avoiding +intefering with it? + +Currently, @code{g77} provides rudimentary ways to choose whether to +overwrite portions of other Fortran compilation systems +(such as the @code{f77} command and the @code{libf2c} library). +Is this sufficient? +What happens when users choose not to overwrite these---does +@code{g77} work properly in all such installations, picking +up its own versions, or does it pick up the existing ``alien'' +versions it didn't overwrite with its own, possibly leading +to subtle bugs? + +@item +@code{LOC()} and other intrinsics are probably somewhat misclassified. +Is the a need for more precise classification of intrinsics, and if so, +what are the appropriate groupings? +Is there a need to individually +enable/disable/delete/hide intrinsics from the command line? +@end itemize + +@node Bugs +@chapter Reporting Bugs +@cindex bugs +@cindex reporting bugs + +Your bug reports play an essential role in making GNU Fortran reliable. + +When you encounter a problem, the first thing to do is to see if it is +already known. +@xref{Trouble}. +If it isn't known, then you should report the problem. + +Reporting a bug might help you by bringing a solution to your problem, or +it might not. +(If it does not, look in the service directory; see +@ref{Service}.)@ +In any case, the principal function of a bug report is +to help the entire community by making the next version of GNU Fortran work +better. +Bug reports are your contribution to the maintenance of GNU Fortran. + +Since the maintainers are very overloaded, we cannot respond to every +bug report. +However, if the bug has not been fixed, we are likely to +send you a patch and ask you to tell us whether it works. + +In order for a bug report to serve its purpose, you must include the +information that makes for fixing the bug. + +@menu +* Criteria: Bug Criteria. Have you really found a bug? +* Where: Bug Lists. Where to send your bug report. +* Reporting: Bug Reporting. How to report a bug effectively. +* Patches: Sending Patches. How to send a patch for GNU Fortran. +@end menu + +@xref{Trouble,,Known Causes of Trouble with GNU Fortran}, +for information on problems we already know about. + +@xref{Service,,How To Get Help with GNU Fortran}, +for information on where to ask for help. + +@node Bug Criteria +@section Have You Found a Bug? +@cindex bug criteria + +If you are not sure whether you have found a bug, here are some guidelines: + +@itemize @bullet +@cindex fatal signal +@cindex core dump +@item +If the compiler gets a fatal signal, for any input whatever, that is a +compiler bug. +Reliable compilers never crash---they just remain obsolete. + +@cindex invalid assembly code +@cindex assembly code, invalid +@item +If the compiler produces invalid assembly code, for any input whatever, +@c (except an @code{asm} statement), +that is a compiler bug, unless the +compiler reports errors (not just warnings) which would ordinarily +prevent the assembler from being run. + +@cindex undefined behavior +@cindex undefined function value +@item +If the compiler produces valid assembly code that does not correctly +execute the input source code, that is a compiler bug. + +However, you must double-check to make sure, because you might have run +into an incompatibility between GNU Fortran and traditional Fortran. +@c (@pxref{Incompatibilities}). +These incompatibilities might be considered +bugs, but they are inescapable consequences of valuable features. + +Or you might have a program whose behavior is undefined, which happened +by chance to give the desired results with another Fortran compiler. +It is best to check the relevant Fortran standard thoroughly if +it is possible that the program indeed does something undefined. + +After you have localized the error to a single source line, it should +be easy to check for these things. +If your program is correct and well defined, you have found +a compiler bug. + +It might help if, in your submission, you identified the specific +language in the relevant Fortran standard that specifies the +desired behavior, if it isn't likely to be obvious and agreed-upon +by all Fortran users. + +@item +If the compiler produces an error message for valid input, that is a +compiler bug. + +@cindex invalid input +@item +If the compiler does not produce an error message for invalid input, +that is a compiler bug. +However, you should note that your idea of +``invalid input'' might be someone else's idea +of ``an extension'' or ``support for traditional practice''. + +@item +If you are an experienced user of Fortran compilers, your suggestions +for improvement of GNU Fortran are welcome in any case. +@end itemize + +@node Bug Lists +@section Where to Report Bugs +@cindex bug report mailing lists +@kindex fortran@@gnu.ai.mit.edu +Send bug reports for GNU Fortran to @email{fortran@@gnu.ai.mit.edu}. + +Often people think of posting bug reports to a newsgroup instead of +mailing them. +This sometimes appears to work, but it has one problem which can be +crucial: a newsgroup posting does not contain a mail path back to the +sender. +Thus, if maintainers need more information, they might be unable +to reach you. For this reason, you should always send bug reports by +mail to the proper mailing list. + +As a last resort, send bug reports on paper to: + +@example +GNU Compiler Bugs +Free Software Foundation +59 Temple Place - Suite 330 +Boston, MA 02111-1307, USA +@end example + +@node Bug Reporting +@section How to Report Bugs +@cindex compiler bugs, reporting + +The fundamental principle of reporting bugs usefully is this: +@strong{report all the facts}. +If you are not sure whether to state a +fact or leave it out, state it! + +Often people omit facts because they think they know what causes the +problem and they conclude that some details don't matter. +Thus, you might +assume that the name of the variable you use in an example does not matter. +Well, probably it doesn't, but one cannot be sure. +Perhaps the bug is a +stray memory reference which happens to fetch from the location where that +name is stored in memory; perhaps, if the name were different, the contents +of that location would fool the compiler into doing the right thing despite +the bug. +Play it safe and give a specific, complete example. +That is the +easiest thing for you to do, and the most helpful. + +Keep in mind that the purpose of a bug report is to enable someone to +fix the bug if it is not known. +It isn't very important what happens if +the bug is already known. +Therefore, always write your bug reports on +the assumption that the bug is not known. + +Sometimes people give a few sketchy facts and ask, ``Does this ring a +bell?'' +This cannot help us fix a bug, so it is rarely helpful. +We respond by asking for enough details to enable us to investigate. +You might as well expedite matters by sending them to begin with. +(Besides, there are enough bells ringing around here as it is.) + +Try to make your bug report self-contained. +If we have to ask you for +more information, it is best if you include all the previous information +in your response, as well as the information that was missing. + +Please report each bug in a separate message. +This makes it easier for +us to track which bugs have been fixed and to forward your bugs reports +to the appropriate maintainer. + +Do not compress and encode any part of your bug report using programs +such as @file{uuencode}. +If you do so it will slow down the processing +of your bug. +If you must submit multiple large files, use @file{shar}, +which allows us to read your message without having to run any +decompression programs. + +(As a special exception for GNU Fortran bug-reporting, at least +for now, if you are sending more than a few lines of code, if +your program's source file format contains ``interesting'' things +like trailing spaces or strange characters, or if you need to +include binary data files, it is acceptable to put all the +files together in a @code{tar} archive, and, whether you need to +do that, it is acceptable to then compress the single file (@code{tar} +archive or source file) +using @code{gzip} and encode it via @code{uuencode}. +Do not use any MIME stuff---the current maintainer can't decode this. +Using @code{compress} instead of @code{gzip} is acceptable, assuming +you have licensed the use of the patented algorithm in +@code{compress} from Unisys.) + +To enable someone to investigate the bug, you should include all these +things: + +@itemize @bullet +@item +The version of GNU Fortran. +You can get this by running @code{g77} with the @samp{-v} option. +(Ignore any error messages that might be displayed +when the linker is run.) + +Without this, we won't know whether there is any point in looking for +the bug in the current version of GNU Fortran. + +@item +@cindex preprocessor +@cindex cpp program +@cindex programs, cpp +A complete input file that will reproduce the bug. +If the bug is in the compiler proper (@file{f771}) and +you are using the C preprocessor, run your +source file through the C preprocessor by doing @samp{g77 -E +@var{sourcefile} > @var{outfile}}, then include the contents of +@var{outfile} in the bug report. (When you do this, use the same +@samp{-I}, @samp{-D} or @samp{-U} options that you used in actual +compilation.) + +A single statement is not enough of an example. +In order to compile it, +it must be embedded in a complete file of compiler input; and the bug +might depend on the details of how this is done. + +Without a real example one can compile, all anyone can do about your bug +report is wish you luck. It would be futile to try to guess how to +provoke the bug. For example, bugs in register allocation and reloading +frequently depend on every little detail of the function they happen in. + +@item +@cindex included files +@cindex INCLUDE directive +@cindex directive, INCLUDE +@cindex #include directive +@cindex directive, #include +Note that you should include with your bug report any files +included by the source file +(via the @code{#include} or @code{INCLUDE} directive) +that you send, and any files they include, and so on. + +It is not necessary to replace +the @code{#include} and @code{INCLUDE} directives +with the actual files in the version of the source file that +you send, but it might make submitting the bug report easier +in the end. +However, be sure to @emph{reproduce} the bug using the @emph{exact} +version of the source material you submit, to avoid wild-goose +chases. + +@item +The command arguments you gave GNU Fortran to compile that example +and observe the bug. For example, did you use @samp{-O}? To guarantee +you won't omit something important, list all the options. + +If we were to try to guess the arguments, we would probably guess wrong +and then we would not encounter the bug. + +@item +The type of machine you are using, and the operating system name and +version number. +(Much of this information is printed by @samp{g77 -v}---if you +include that, send along any additional info you have that you +don't see clearly represented in that output.) + +@item +The operands you gave to the @code{configure} command when you installed +the compiler. + +@item +A complete list of any modifications you have made to the compiler +source. (We don't promise to investigate the bug unless it happens in +an unmodified compiler. But if you've made modifications and don't tell +us, then you are sending us on a wild-goose chase.) + +Be precise about these changes. A description in English is not +enough---send a context diff for them. + +Adding files of your own (such as a machine description for a machine we +don't support) is a modification of the compiler source. + +@item +Details of any other deviations from the standard procedure for installing +GNU Fortran. + +@item +A description of what behavior you observe that you believe is +incorrect. For example, ``The compiler gets a fatal signal,'' or, +``The assembler instruction at line 208 in the output is incorrect.'' + +Of course, if the bug is that the compiler gets a fatal signal, then one +can't miss it. But if the bug is incorrect output, the maintainer might +not notice unless it is glaringly wrong. None of us has time to study +all the assembler code from a 50-line Fortran program just on the chance that +one instruction might be wrong. We need @emph{you} to do this part! + +Even if the problem you experience is a fatal signal, you should still +say so explicitly. Suppose something strange is going on, such as, your +copy of the compiler is out of synch, or you have encountered a bug in +the C library on your system. (This has happened!) Your copy might +crash and the copy here would not. If you @i{said} to expect a crash, +then when the compiler here fails to crash, we would know that the bug +was not happening. If you don't say to expect a crash, then we would +not know whether the bug was happening. We would not be able to draw +any conclusion from our observations. + +If the problem is a diagnostic when building GNU Fortran with some other +compiler, say whether it is a warning or an error. + +Often the observed symptom is incorrect output when your program is run. +Sad to say, this is not enough information unless the program is short +and simple. None of us has time to study a large program to figure out +how it would work if compiled correctly, much less which line of it was +compiled wrong. So you will have to do that. Tell us which source line +it is, and what incorrect result happens when that line is executed. A +person who understands the program can find this as easily as finding a +bug in the program itself. + +@item +If you send examples of assembler code output from GNU Fortran, +please use @samp{-g} when you make them. The debugging information +includes source line numbers which are essential for correlating the +output with the input. + +@item +If you wish to mention something in the GNU Fortran source, refer to it by +context, not by line number. + +The line numbers in the development sources don't match those in your +sources. Your line numbers would convey no convenient information to the +maintainers. + +@item +Additional information from a debugger might enable someone to find a +problem on a machine which he does not have available. However, you +need to think when you collect this information if you want it to have +any chance of being useful. + +@cindex backtrace for bug reports +For example, many people send just a backtrace, but that is never +useful by itself. A simple backtrace with arguments conveys little +about GNU Fortran because the compiler is largely data-driven; the same +functions are called over and over for different RTL insns, doing +different things depending on the details of the insn. + +Most of the arguments listed in the backtrace are useless because they +are pointers to RTL list structure. The numeric values of the +pointers, which the debugger prints in the backtrace, have no +significance whatever; all that matters is the contents of the objects +they point to (and most of the contents are other such pointers). + +In addition, most compiler passes consist of one or more loops that +scan the RTL insn sequence. The most vital piece of information about +such a loop---which insn it has reached---is usually in a local variable, +not in an argument. + +@findex debug_rtx +What you need to provide in addition to a backtrace are the values of +the local variables for several stack frames up. When a local +variable or an argument is an RTX, first print its value and then use +the GDB command @code{pr} to print the RTL expression that it points +to. (If GDB doesn't run on your machine, use your debugger to call +the function @code{debug_rtx} with the RTX as an argument.) In +general, whenever a variable is a pointer, its value is no use +without the data it points to. +@end itemize + +Here are some things that are not necessary: + +@itemize @bullet +@item +A description of the envelope of the bug. + +Often people who encounter a bug spend a lot of time investigating +which changes to the input file will make the bug go away and which +changes will not affect it. + +This is often time consuming and not very useful, because the way we +will find the bug is by running a single example under the debugger with +breakpoints, not by pure deduction from a series of examples. You might +as well save your time for something else. + +Of course, if you can find a simpler example to report @emph{instead} of +the original one, that is a convenience. Errors in the output will be +easier to spot, running under the debugger will take less time, etc. +Most GNU Fortran bugs involve just one function, so the most straightforward +way to simplify an example is to delete all the function definitions +except the one where the bug occurs. Those earlier in the file may be +replaced by external declarations if the crucial function depends on +them. (Exception: inline functions might affect compilation of functions +defined later in the file.) + +However, simplification is not vital; if you don't want to do this, +report the bug anyway and send the entire test case you used. + +@item +In particular, some people insert conditionals @samp{#ifdef BUG} around +a statement which, if removed, makes the bug not happen. These are just +clutter; we won't pay any attention to them anyway. Besides, you should +send us preprocessor output, and that can't have conditionals. + +@item +A patch for the bug. + +A patch for the bug is useful if it is a good one. But don't omit the +necessary information, such as the test case, on the assumption that a +patch is all we need. We might see problems with your patch and decide +to fix the problem another way, or we might not understand it at all. + +Sometimes with a program as complicated as GNU Fortran it is very hard to +construct an example that will make the program follow a certain path +through the code. If you don't send the example, we won't be able to +construct one, so we won't be able to verify that the bug is fixed. + +And if we can't understand what bug you are trying to fix, or why your +patch should be an improvement, we won't install it. A test case will +help us to understand. + +@xref{Sending Patches}, for guidelines on how to make it easy for us to +understand and install your patches. + +@item +A guess about what the bug is or what it depends on. + +Such guesses are usually wrong. Even the maintainer can't guess right +about such things without first using the debugger to find the facts. + +@item +A core dump file. + +We have no way of examining a core dump for your type of machine +unless we have an identical system---and if we do have one, +we should be able to reproduce the crash ourselves. +@end itemize + +@node Sending Patches +@section Sending Patches for GNU Fortran + +If you would like to write bug fixes or improvements for the GNU Fortran +compiler, that is very helpful. +Send suggested fixes to the bug report +mailing list, @email{fortran@@gnu.ai.mit.edu}. + +Please follow these guidelines so we can study your patches efficiently. +If you don't follow these guidelines, your information might still be +useful, but using it will take extra work. Maintaining GNU Fortran is a lot +of work in the best of circumstances, and we can't keep up unless you do +your best to help. + +@itemize @bullet +@item +Send an explanation with your changes of what problem they fix or what +improvement they bring about. For a bug fix, just include a copy of the +bug report, and explain why the change fixes the bug. + +(Referring to a bug report is not as good as including it, because then +we will have to look it up, and we have probably already deleted it if +we've already fixed the bug.) + +@item +Always include a proper bug report for the problem you think you have +fixed. We need to convince ourselves that the change is right before +installing it. Even if it is right, we might have trouble judging it if +we don't have a way to reproduce the problem. + +@item +Include all the comments that are appropriate to help people reading the +source in the future understand why this change was needed. + +@item +Don't mix together changes made for different reasons. +Send them @emph{individually}. + +If you make two changes for separate reasons, then we might not want to +install them both. We might want to install just one. If you send them +all jumbled together in a single set of diffs, we have to do extra work +to disentangle them---to figure out which parts of the change serve +which purpose. If we don't have time for this, we might have to ignore +your changes entirely. + +If you send each change as soon as you have written it, with its own +explanation, then the two changes never get tangled up, and we can +consider each one properly without any extra work to disentangle them. + +Ideally, each change you send should be impossible to subdivide into +parts that we might want to consider separately, because each of its +parts gets its motivation from the other parts. + +@item +Send each change as soon as that change is finished. Sometimes people +think they are helping us by accumulating many changes to send them all +together. As explained above, this is absolutely the worst thing you +could do. + +Since you should send each change separately, you might as well send it +right away. That gives us the option of installing it immediately if it +is important. + +@item +Use @samp{diff -c} to make your diffs. Diffs without context are hard +for us to install reliably. More than that, they make it hard for us to +study the diffs to decide whether we want to install them. Unidiff +format is better than contextless diffs, but not as easy to read as +@samp{-c} format. + +If you have GNU @code{diff}, use @samp{diff -cp}, which shows the name of the +function that each change occurs in. +(The maintainer of GNU Fortran currently uses @samp{diff -rcp2N}.) + +@item +Write the change log entries for your changes. We get lots of changes, +and we don't have time to do all the change log writing ourselves. + +Read the @file{ChangeLog} file to see what sorts of information to put +in, and to learn the style that we use. The purpose of the change log +is to show people where to find what was changed. So you need to be +specific about what functions you changed; in large functions, it's +often helpful to indicate where within the function the change was. + +On the other hand, once you have shown people where to find the change, +you need not explain its purpose. Thus, if you add a new function, all +you need to say about it is that it is new. If you feel that the +purpose needs explaining, it probably does---but the explanation will be +much more useful if you put it in comments in the code. + +If you would like your name to appear in the header line for who made +the change, send us the header line. + +@item +When you write the fix, keep in mind that we can't install a change that +would break other systems. + +People often suggest fixing a problem by changing machine-independent +files such as @file{toplev.c} to do something special that a particular +system needs. Sometimes it is totally obvious that such changes would +break GNU Fortran for almost all users. We can't possibly make a change like +that. At best it might tell us how to write another patch that would +solve the problem acceptably. + +Sometimes people send fixes that @emph{might} be an improvement in +general---but it is hard to be sure of this. It's hard to install +such changes because we have to study them very carefully. Of course, +a good explanation of the reasoning by which you concluded the change +was correct can help convince us. + +The safest changes are changes to the configuration files for a +particular machine. These are safe because they can't create new bugs +on other machines. + +Please help us keep up with the workload by designing the patch in a +form that is good to install. +@end itemize + +@node Service +@chapter How To Get Help with GNU Fortran + +If you need help installing, using or changing GNU Fortran, there are two +ways to find it: + +@itemize @bullet +@item +Look in the service directory for someone who might help you for a fee. +The service directory is found in the file named @file{SERVICE} in the +GNU CC distribution. + +@item +Send a message to @email{fortran@@gnu.ai.mit.edu}. +@end itemize + +@end ifset +@ifset INTERNALS +@node Adding Options +@chapter Adding Options +@cindex options, adding +@cindex adding options + +To add a new command-line option to @code{g77}, first decide +what kind of option you wish to add. +Search the @code{g77} and @code{gcc} documentation for one +or more options that is most closely like the one you want to add +(in terms of what kind of effect it has, and so on) to +help clarify its nature. + +@itemize @bullet +@item +@emph{Fortran options} are options that apply only +when compiling Fortran programs. +They are accepted by @code{g77} and @code{gcc}, but +they apply only when compiling Fortran programs. + +@item +@emph{Compiler options} are options that apply +when compiling most any kind of program. +@end itemize + +@emph{Fortran options} are listed in the file +@file{gcc/f/lang-options.h}, +which is used during the build of @code{gcc} to +build a list of all options that are accepted by +at least one language's compiler. +This list goes into the @samp{lang_options} array +in @file{gcc/toplev.c}, which uses this array to +determine whether a particular option should be +offered to the linked-in front end for processing +by calling @samp{lang_option_decode}, which, for +@code{g77}, is in @file{gcc/f/com.c} and just +calls @samp{ffe_decode_option}. + +If the linked-in front end ``rejects'' a +particular option passed to it, @file{toplev.c} +just ignores the option, because @emph{some} +language's compiler is willing to accept it. + +This allows commands like @samp{gcc -fno-asm foo.c bar.f} +to work, even though Fortran compilation does +not currently support the @samp{-fno-asm} option; +even though the @code{f771} version of @samp{lang_decode_option} +rejects @samp{-fno-asm}, @file{toplev.c} doesn't +produce a diagnostic because some other language (C) +does accept it. + +This also means that commands like +@samp{g77 -fno-asm foo.f} yield no diagnostics, +despite the fact that no phase of the command was +able to recognize and process @samp{-fno-asm}---perhaps +a warning about this would be helpful if it were +possible. + +Code that processes Fortran options is found in +@file{gcc/f/top.c}, function @samp{ffe_decode_option}. +This code needs to check positive and negative forms +of each option. + +The defaults for Fortran options are set in their +global definitions, also found in @file{gcc/f/top.c}. +Many of these defaults are actually macros defined +in @file{gcc/f/target.h}, since they might be +machine-specific. +However, since, in practice, GNU compilers +should behave the same way on all configurations +(especially when it comes to language constructs), +the practice of setting defaults in @file{target.h} +is likely to be deprecated and, ultimately, stopped +in future versions of @code{g77}. + +Accessor macros for Fortran options, used by code +in the @code{g77} FFE, are defined in @file{gcc/f/top.h}. + +@emph{Compiler options} are listed in @file{gcc/toplev.c} +in the array @samp{f_options}. +An option not listed in @samp{lang_options} is +looked up in @samp{f_options} and handled from there. + +The defaults for compiler options are set in the +global definitions for the corresponding variables, +some of which are in @file{gcc/toplev.c}. + +You can set different defaults for @emph{Fortran-oriented} +or @emph{Fortran-reticent} compiler options by changing +the way @code{f771} handles the @samp{-fset-g77-defaults} +option, which is always provided as the first option when +called by @code{g77} or @code{gcc}. + +This code is in @samp{ffe_decode_options} in @file{gcc/f/top.c}. +Have it change just the variables that you want to default +to a different setting for Fortran compiles compared to +compiles of other languages. + +The @samp{-fset-g77-defaults} option is passed to @code{f771} +automatically because of the specification information +kept in @file{gcc/f/lang-specs.h}. +This file tells the @code{gcc} command how to recognize, +in this case, Fortran source files (those to be preprocessed, +and those that are not), and further, how to invoke the +appropriate programs (including @code{f771}) to process +those source files. + +It is in @file{gcc/f/lang-specs.h} that @samp{-fset-g77-defaults}, +@samp{-fversion}, and other options are passed, as appropriate, +even when the user has not explicitly specified them. +Other ``internal'' options such as @samp{-quiet} also +are passed via this mechanism. + +@node Projects +@chapter Projects +@cindex projects + +If you want to contribute to @code{g77} by doing research, +design, specification, documentation, coding, or testing, +the following information should give you some ideas. + +@menu +* Efficiency:: Make @code{g77} itself compile code faster. +* Better Optimization:: Teach @code{g77} to generate faster code. +* Simplify Porting:: Make @code{g77} easier to configure, build, + and install. +* More Extensions:: Features many users won't know to ask for. +* Machine Model:: @code{g77} should better leverage @code{gcc}. +* Internals Documentation:: Make maintenance easier. +* Internals Improvements:: Make internals more robust. +* Better Diagnostics:: Make using @code{g77} on new code easier. +@end menu + +@node Efficiency +@section Improve Efficiency +@cindex efficiency + +Don't bother doing any performance analysis until most of the +following items are taken care of, because there's no question +they represent serious space/time problems, although some of +them show up only given certain kinds of (popular) input. + +@itemize @bullet +@item +Improve @samp{malloc} package and its uses to specify more info about +memory pools and, where feasible, use obstacks to implement them. + +@item +Skip over uninitialized portions of aggregate areas (arrays, +@code{COMMON} areas, @code{EQUIVALENCE} areas) so zeros need not be output. +This would reduce memory usage for large initialized aggregate +areas, even ones with only one initialized element. + +As of version 0.5.18, a portion of this item has already been +accomplished. + +@item +Prescan the statement (in @file{sta.c}) so that the nature of the statement +is determined as much as possible by looking entirely at its form, +and not looking at any context (previous statements, including types +of symbols). +This would allow ripping out of the statement-confirmation, +symbol retraction/confirmation, and diagnostic inhibition +mechanisms. +Plus, it would result in much-improved diagnostics. +For example, @samp{CALL some-intrinsic(@dots{})}, where the intrinsic +is not a subroutine intrinsic, would result actual error instead of the +unimplemented-statement catch-all. + +@item +Throughout @code{g77}, don't pass line/column pairs where +a simple @samp{ffewhere} type, which points to the error as much as is +desired by the configuration, will do, and don't pass @samp{ffelexToken} types +where a simple @samp{ffewhere} type will do. +Then, allow new default +configuration of @samp{ffewhere} such that the source line text is not +preserved, and leave it to things like Emacs' next-error function +to point to them (now that @samp{next-error} supports column, +or, perhaps, character-offset, numbers). +The change in calling sequences should improve performance somewhat, +as should not having to save source lines. +(Whether this whole +item will improve performance is questionable, but it should +improve maintainability.) + +@item +Handle @samp{DATA (A(I),I=1,1000000)/1000000*2/} more efficiently, especially +as regards the assembly output. +Some of this might require improving +the back end, but lots of improvement in space/time required in @code{g77} +itself can be fairly easily obtained without touching the back end. +Maybe type-conversion, where necessary, can be speeded up as well in +cases like the one shown (converting the @samp{2} into @samp{2.}). + +@item +If analysis shows it to be worthwhile, optimize @file{lex.c}. + +@item +Consider redesigning @file{lex.c} to not need any feedback +during tokenization, by keeping track of enough parse state on its +own. +@end itemize + +@node Better Optimization +@section Better Optimization +@cindex optimization, better +@cindex code generation, improving + +Much of this work should be put off until after @code{g77} has +all the features necessary for its widespread acceptance as a +useful F77 compiler. +However, perhaps this work can be done in parallel during +the feature-adding work. + +@itemize @bullet +@item +Do the equivalent of the trick of putting @samp{extern inline} in front +of every function definition in @code{libf2c} and #include'ing the resulting +file in @code{f2c}+@code{gcc}---that is, inline all run-time-library functions +that are at all worth inlining. +(Some of this has already been done, such as for integral exponentiation.) + +@item +When doing @samp{CHAR_VAR = CHAR_FUNC(@dots{})}, +and it's clear that types line up +and @samp{CHAR_VAR} is addressable or not a @samp{VAR_DECL}, +make @samp{CHAR_VAR}, not a +temporary, be the receiver for @samp{CHAR_FUNC}. +(This is now done for @code{COMPLEX} variables.) + +@item +Design and implement Fortran-specific optimizations that don't +really belong in the back end, or where the front end needs to +give the back end more info than it currently does. + +@item +Design and implement a new run-time library interface, with the +code going into @code{libgcc} so no special linking is required to +link Fortran programs using standard language features. +This library +would speed up lots of things, from I/O (using precompiled formats, +doing just one, or, at most, very few, calls for arrays or array sections, +and so on) to general computing (array/section implementations of +various intrinsics, implementation of commonly performed loops that +aren't likely to be optimally compiled otherwise, etc.). + +Among the important things the library would do are: + +@itemize @bullet +@item +Be a one-stop-shop-type +library, hence shareable and usable by all, in that what are now +library-build-time options in @code{libf2c} would be moved at least to the +@code{g77} compile phase, if not to finer grains (such as choosing how +list-directed I/O formatting is done by default at @code{OPEN} time, for +preconnected units via options or even statements in the main program +unit, maybe even on a per-I/O basis with appropriate pragma-like +devices). +@end itemize + +@item +Probably requiring the new library design, change interface to +normally have @code{COMPLEX} functions return their values in the way +@code{gcc} would if they were declared @code{__complex__ float}, +rather than using +the mechanism currently used by @code{CHARACTER} functions (whereby the +functions are compiled as returning void and their first arg is +a pointer to where to store the result). +(Don't append underscores to +external names for @code{COMPLEX} functions in some cases once @code{g77} uses +@code{gcc} rather than @code{f2c} calling conventions.) + +@item +Do something useful with @samp{doiter} references where possible. +For example, @samp{CALL FOO(I)} cannot modify @samp{I} if within +a @code{DO} loop that uses @samp{I} as the +iteration variable, and the back end might find that info useful +in determining whether it needs to read @samp{I} back into a register after +the call. +(It normally has to do that, unless it knows @samp{FOO} never +modifies its passed-by-reference argument, which is rarely the case +for Fortran-77 code.) +@end itemize + +@node Simplify Porting +@section Simplify Porting +@cindex porting, simplify +@cindex simplify porting + +Making @code{g77} easier to configure, port, build, and install, either +as a single-system compiler or as a cross-compiler, would be +very useful. + +@itemize @bullet +@item +A new library (replacing @code{libf2c}) should improve portability as well as +produce more optimal code. +Further, @code{g77} and the new library should +conspire to simplify naming of externals, such as by removing unnecessarily +added underscores, and to reduce/eliminate the possibility of naming +conflicts, while making debugger more straightforward. + +Also, it should +make multi-language applications more feasible, such as by providing +Fortran intrinsics that get Fortran unit numbers given C @code{FILE *} +descriptors. + +@item +Possibly related to a new library, @code{g77} should produce the equivalent +of a @code{gcc} @samp{main(argc, argv)} function when it compiles a +main program unit, instead of compiling something that must be +called by a library +implementation of @code{main()}. + +This would do many useful things such as +provide more flexibility in terms of setting up exception handling, +not requiring programmers to start their debugging sessions with +@kbd{breakpoint MAIN__} followed by @kbd{run}, and so on. + +@item +The GBE needs to understand the difference between alignment +requirements and desires. +For example, on Intel x86 machines, @code{g77} currently imposes +overly strict alignment requirements, due to the back end, but it +would be useful for Fortran and C programmers to be able to override +these @emph{recommendations} as long as they don't violate the actual +processor @emph{requirements}. +@end itemize + +@node More Extensions +@section More Extensions +@cindex extensions, more + +These extensions are not the sort of things users ask for ``by name'', +but they might improve the usability of @code{g77}, and Fortran in +general, in the long run. +Some of these items really pertain to improving @code{g77} internals +so that some popular extensions can be more easily supported. + +@itemize @bullet +@item +Look through all the documentation on the GNU Fortran language, +dialects, compiler, missing features, bugs, and so on. +Many mentions of incomplete or missing features are +sprinkled throughout. +It is not worth repeating them here. + +@item +@cindex concatenation +@cindex CHARACTER*(*) +Support arbitrary operands for concatenation, even in contexts where +run-time allocation is required. + +@item +Consider adding a @code{NUMERIC} type to designate typeless numeric constants, +named and unnamed. +The idea is to provide a forward-looking, effective +replacement for things like the old-style @code{PARAMETER} statement +when people +really need typelessness in a maintainable, portable, clearly documented +way. +Maybe @code{TYPELESS} would include @code{CHARACTER}, @code{POINTER}, +and whatever else might come along. +(This is not really a call for polymorphism per se, just +an ability to express limited, syntactic polymorphism.) + +@item +Support @samp{OPEN(@dots{},KEY=(@dots{}),@dots{})}. + +@item +Support arbitrary file unit numbers, instead of limiting them +to 0 through @samp{MXUNIT-1}. +(This is a @code{libf2c} issue.) + +@item +@samp{OPEN(NOSPANBLOCKS,@dots{})} is treated as +@samp{OPEN(UNIT=NOSPANBLOCKS,@dots{})}, so a +later @code{UNIT=} in the first example is invalid. +Make sure this is what users of this feature would expect. + +@item +Currently @code{g77} disallows @samp{READ(1'10)} since +it is an obnoxious syntax, but +supporting it might be pretty easy if needed. +More details are needed, such +as whether general expressions separated by an apostrophe are supported, +or maybe the record number can be a general expression, and so on. + +@item +Support @code{STRUCTURE}, @code{UNION}, @code{MAP}, and @code{RECORD} +fully. +Currently there is no support at all +for @code{%FILL} in @code{STRUCTURE} and related syntax, +whereas the rest of the +stuff has at least some parsing support. +This requires either major +changes to @code{libf2c} or its replacement. + +@item +F90 and @code{g77} probably disagree about label scoping relative to +@code{INTERFACE} and @code{END INTERFACE}, and their contained +procedure interface bodies (blocks?). + +@item +@code{ENTRY} doesn't support F90 @code{RESULT()} yet, +since that was added after S8.112. + +@item +Empty-statement handling (10 ;;CONTINUE;;) probably isn't consistent +with the final form of the standard (it was vague at S8.112). + +@item +It seems to be an ``open'' question whether a file, immediately after being +@code{OPEN}ed,is positioned at the beginning, the end, or wherever---it +might be nice to offer an option of opening to ``undefined'' status, requiring +an explicit absolute-positioning operation to be performed before any +other (besides @code{CLOSE}) to assist in making applications port to systems +(some IBM?) that @code{OPEN} to the end of a file or some such thing. +@end itemize + +@node Machine Model +@section Machine Model + +This items pertain to generalizing @code{g77}'s view of +the machine model to more fully accept whatever the GBE +provides it via its configuration. + +@itemize @bullet +@item +Switch to using @samp{REAL_VALUE_TYPE} to represent floating-point constants +exclusively so the target float format need not be required. +This +means changing the way @code{g77} handles initialization of aggregate areas +having more than one type, such as @code{REAL} and @code{INTEGER}, +because currently +it initializes them as if they were arrays of @code{char} and uses the +bit patterns of the constants of the various types in them to determine +what to stuff in elements of the arrays. + +@item +Rely more and more on back-end info and capabilities, especially in the +area of constants (where having the @code{g77} front-end's IL just store +the appropriate tree nodes containing constants might be best). + +@item +Suite of C and Fortran programs that a user/administrator can run on a +machine to help determine the configuration for @code{g77} before building +and help determine if the compiler works (especially with whatever +libraries are installed) after building. +@end itemize + +@node Internals Documentation +@section Internals Documentation + +Better info on how @code{g77} works and how to port it is needed. +Much of this should be done only after the redesign planned for +0.6 is complete. + +@node Internals Improvements +@section Internals Improvements + +Some more items that would make @code{g77} more reliable +and easier to maintain: + +@itemize @bullet +@item +Generally make expression handling focus +more on critical syntax stuff, leaving semantics to callers. +For example, +anything a caller can check, semantically, let it do so, rather +than having @file{expr.c} do it. +(Exceptions might include things like +diagnosing @samp{FOO(I--K:)=BAR} where @samp{FOO} is a @code{PARAMETER}---if +it seems +important to preserve the left-to-right-in-source order of production +of diagnostics.) + +@item +Come up with better naming conventions for @samp{-D} to establish requirements +to achieve desired implementation dialect via @file{proj.h}. + +@item +Clean up used tokens and @samp{ffewhere}s in @samp{ffeglobal_terminate_1}. + +@item +Replace @file{sta.c} @samp{outpooldisp} mechanism with @samp{malloc_pool_use}. + +@item +Check for @samp{opANY} in more places in @file{com.c}, @file{std.c}, +and @file{ste.c}, and get rid of the @samp{opCONVERT(opANY)} kludge +(after determining if there is indeed no real need for it). + +@item +Utility to read and check @file{bad.def} messages and their references in the +code, to make sure calls are consistent with message templates. + +@item +Search and fix @samp{&ffe@dots{}} and similar so that +@samp{ffe@dots{}ptr@dots{}} macros are +available instead (a good argument for wishing this could have written all +this stuff in C++, perhaps). +On the other hand, it's questionable whether this sort of +improvement is really necessary, given the availability of +tools such as Emacs and Perl, which make finding any +address-taking of structure members easy enough? + +@item +Some modules truly export the member names of their structures (and the +structures themselves), maybe fix this, and fix other modules that just +appear to as well (by appending @samp{_}, though it'd be ugly and probably +not worth the time). + +@item +Implement C macros @samp{RETURNS(value)} and @samp{SETS(something,value)} +in @file{proj.h} +and use them throughout @code{g77} source code (especially in the definitions +of access macros in @samp{.h} files) so they can be tailored +to catch code writing into a @samp{RETURNS()} or reading from a @samp{SETS()}. + +@item +Decorate throughout with @code{const} and other such stuff. + +@item +All F90 notational derivations in the source code are still based +on the S8.112 version of the draft standard. +Probably should update +to the official standard, or put documentation of the rules as used +in the code@dots{}uh@dots{}in the code. + +@item +Some @samp{ffebld_new} calls (those outside of @file{ffeexpr.c} or +inside but invoked via paths not involving @samp{ffeexpr_lhs} or +@samp{ffeexpr_rhs}) might be creating things +in improper pools, leading to such things staying around too long or +(doubtful, but possible and dangerous) not long enough. + +@item +Some @samp{ffebld_list_new} (or whatever) calls might not be matched by +@samp{ffebld_list_bottom} (or whatever) calls, which might someday matter. +(It definitely is not a problem just yet.) + +@item +Probably not doing clean things when we fail to @code{EQUIVALENCE} something +due to alignment/mismatch or other problems---they end up without +@samp{ffestorag} objects, so maybe the backend (and other parts of the front +end) can notice that and handle like an @samp{opANY} (do what it wants, just +don't complain or crash). +Most of this seems to have been addressed +by now, but a code review wouldn't hurt. +@end itemize + +@node Better Diagnostics +@section Better Diagnostics + +These are things users might not ask about, or that need to +be looked into, before worrying about. +Also here are items that involve reducing unnecessary diagnostic +clutter. + +@itemize @bullet +@item +When @code{FUNCTION} and @code{ENTRY} point types disagree (@code{CHARACTER} +lengths, type classes, and so on), +@samp{ANY}-ize the offending @code{ENTRY} point and any @emph{new} dummies +it specifies. + +@item +Speed up and improve error handling for data when repeat-count is +specified. +For example, don't output 20 unnecessary messages after the +first necessary one for: + +@smallexample +INTEGER X(20) +CONTINUE +DATA (X(I), J= 1, 20) /20*5/ +END +@end smallexample + +@noindent +(The @code{CONTINUE} statement ensures the @code{DATA} statement +is processed in the context of executable, not specification, +statements.) +@end itemize +@end ifset + +@ifset USING +@node Diagnostics +@chapter Diagnostics +@cindex diagnostics + +Some diagnostics produced by @code{g77} require sufficient explanation +that the explanations are given below, and the diagnostics themselves +identify the appropriate explanation. + +Identification uses the GNU Info format---specifically, the @code{info} +command that displays the explanation is given in within square +brackets in the diagnostic. +For example: + +@smallexample +foo.f:5: Invalid statement [info -f g77 M FOOEY] +@end smallexample + +More details about the above diagnostic is found in the @code{g77} Info +documentation, menu item @samp{M}, submenu item @samp{FOOEY}, +which is displayed by typing the UNIX command +@samp{info -f g77 M FOOEY}. + +Other Info readers, such as EMACS, may be just as easily used to display +the pertinent node. +In the above example, @samp{g77} is the Info document name, +@samp{M} is the top-level menu item to select, +and, in that node (named @samp{Diagnostics}, the name of +this chapter, which is the very text you're reading now), +@samp{FOOEY} is the menu item to select. + +@iftex +In this printed version of the @code{g77} manual, the above example +points to a section, below, entitled @samp{FOOEY}---though, of course, +as the above is just a sample, no such section exists. +@end iftex + +@menu +* CMPAMBIG:: Ambiguous use of intrinsic. +* EXPIMP:: Intrinsic used explicitly and implicitly. +* INTGLOB:: Intrinsic also used as name of global. +* LEX:: Various lexer messages +* GLOBALS:: Disagreements about globals. +@end menu + +@node CMPAMBIG +@section @code{CMPAMBIG} + +@noindent +@smallexample +Ambiguous use of intrinsic @var{intrinsic} @dots{} +@end smallexample + +The type of the argument to the invocation of the @var{intrinsic} +intrinsic is a @code{COMPLEX} type other than @code{COMPLEX(KIND=1)}. +Typically, it is @code{COMPLEX(KIND=2)}, also known as +@code{DOUBLE COMPLEX}. + +The interpretation of this invocation depends on the particular +dialect of Fortran for which the code was written. +Some dialects convert the real part of the argument to +@code{REAL(KIND=1)}, thus losing precision; other dialects, +and Fortran 90, do no such conversion. + +So, GNU Fortran rejects such invocations except under certain +circumstances, to avoid making an incorrect assumption that results +in generating the wrong code. + +To determine the dialect of the program unit, perhaps even whether +that particular invocation is properly coded, determine how the +result of the intrinsic is used. + +The result of @var{intrinsic} is expected (by the original programmer) +to be @code{REAL(KIND=1)} (the non-Fortran-90 interpretation) if: + +@itemize @bullet +@item +It is passed as an argument to a procedure that explicitly or +implicitly declares that argument @code{REAL(KIND=1)}. + +For example, +a procedure with no @code{DOUBLE PRECISION} or @code{IMPLICIT DOUBLE PRECISION} +statement specifying the dummy argument corresponding to an +actual argument of @samp{REAL(Z)}, where @samp{Z} is declared +@code{DOUBLE COMPLEX}, strongly suggests that the programmer +expected @samp{REAL(Z)} to return @code{REAL(KIND=1)} instead +of @code{REAL(KIND=2)}. + +@item +It is used in a context that would otherwise not include +any @code{REAL(KIND=2)} but where treating the @var{intrinsic} +invocation as @code{REAL(KIND=2)} would result in unnecessary +promotions and (typically) more expensive operations on the +wider type. + +For example: + +@smallexample +DOUBLE COMPLEX Z +@dots{} +R(1) = T * REAL(Z) +@end smallexample + +The above example suggests the programmer expected the real part +of @samp{Z} to be converted to @code{REAL(KIND=1)} before being +multiplied by @samp{T} (presumed, along with @samp{R} above, to +be type @code{REAL(KIND=1)}). + +Otherwise, the conversion would have to be delayed until after +the multiplication, requiring not only an extra conversion +(of @samp{T} to @code{REAL(KIND=2)}), but a (typically) more +expensive multiplication (a double-precision multiplication instead +of a single-precision one). +@end itemize + +The result of @var{intrinsic} is expected (by the original programmer) +to be @code{REAL(KIND=2)} (the Fortran 90 interpretation) if: + +@itemize @bullet +@item +It is passed as an argument to a procedure that explicitly or +implicitly declares that argument @code{REAL(KIND=2)}. + +For example, a procedure specifying a @code{DOUBLE PRECISION} +dummy argument corresponding to an +actual argument of @samp{REAL(Z)}, where @samp{Z} is declared +@code{DOUBLE COMPLEX}, strongly suggests that the programmer +expected @samp{REAL(Z)} to return @code{REAL(KIND=2)} instead +of @code{REAL(KIND=1)}. + +@item +It is used in an expression context that includes +other @code{REAL(KIND=2)} operands, +or is assigned to a @code{REAL(KIND=2)} variable or array element. + +For example: + +@smallexample +DOUBLE COMPLEX Z +DOUBLE PRECISION R, T +@dots{} +R(1) = T * REAL(Z) +@end smallexample + +The above example suggests the programmer expected the real part +of @samp{Z} to @emph{not} be converted to @code{REAL(KIND=1)} +by the @code{REAL()} intrinsic. + +Otherwise, the conversion would have to be immediately followed +by a conversion back to @code{REAL(KIND=2)}, losing +the original, full precision of the real part of @code{Z}, +before being multiplied by @samp{T}. +@end itemize + +Once you have determined whether a particular invocation of @var{intrinsic} +expects the Fortran 90 interpretation, you can: + +@itemize @bullet +@item +Change it to @samp{DBLE(@var{expr})} (if @var{intrinsic} is +@samp{REAL}) or @samp{DIMAG(@var{expr})} (if @var{intrinsic} +is @samp{AIMAG}) +if it expected the Fortran 90 interpretation. + +This assumes @var{expr} is @code{COMPLEX(KIND=2)}---if it is +some other type, such as @code{COMPLEX*32}, you should use the +appropriate intrinsic, such as the one to convert to @code{REAL*16} +(perhaps @code{DBLEQ()} in place of @code{DBLE()}, and +@code{QIMAG()} in place of @code{DIMAG()}). + +@item +Change it to @samp{REAL(@var{intrinsic}(@var{expr}))}, +otherwise. +This converts to @code{REAL(KIND=1)} in all working +Fortran compilers. +@end itemize + +If you don't want to change the code, and you are certain that all +ambiguous invocations of @var{intrinsic} in the source file have +the same expectation regarding interpretation, you can: + +@itemize @bullet +@item +Compile with the @code{g77} option @samp{-ff90}, to enable the +Fortran 90 interpretation. + +@item +Compile with the @code{g77} options @samp{-fno-f90 -fugly-complex}, +to enable the non-Fortran-90 interpretations. +@end itemize + +@xref{REAL() and AIMAG() of Complex}, for more information on this +issue. + +Note: If the above suggestions don't produce enough evidence +as to whether a particular program expects the Fortran 90 +interpretation of this ambiguous invocation of @var{intrinsic}, +there is one more thing you can try. + +If you have access to most or all the compilers used on the +program to create successfully tested and deployed executables, +read the documentation for, and @emph{also} test out, each compiler +to determine how it treats the @var{intrinsic} intrinsic in +this case. +(If all the compilers don't agree on an interpretation, there +might be lurking bugs in the deployed versions of the program.) + +The following sample program might help: + +@cindex JCB003 program +@smallexample + PROGRAM JCB003 +C +C Written by James Craig Burley 1997-02-23. +C Contact via Internet email: burley@@gnu.ai.mit.edu +C +C Determine how compilers handle non-standard REAL +C and AIMAG on DOUBLE COMPLEX operands. +C + DOUBLE COMPLEX Z + REAL R + Z = (3.3D0, 4.4D0) + R = Z + CALL DUMDUM(Z, R) + R = REAL(Z) - R + IF (R .NE. 0.) PRINT *, 'REAL() is Fortran 90' + IF (R .EQ. 0.) PRINT *, 'REAL() is not Fortran 90' + R = 4.4D0 + CALL DUMDUM(Z, R) + R = AIMAG(Z) - R + IF (R .NE. 0.) PRINT *, 'AIMAG() is Fortran 90' + IF (R .EQ. 0.) PRINT *, 'AIMAG() is not Fortran 90' + END +C +C Just to make sure compiler doesn't use naive flow +C analysis to optimize away careful work above, +C which might invalidate results.... +C + SUBROUTINE DUMDUM(Z, R) + DOUBLE COMPLEX Z + REAL R + END +@end smallexample + +If the above program prints contradictory results on a +particular compiler, run away! + +@node EXPIMP +@section @code{EXPIMP} + +@noindent +@smallexample +Intrinsic @var{intrinsic} referenced @dots{} +@end smallexample + +The @var{intrinsic} is explicitly declared in one program +unit in the source file and implicitly used as an intrinsic +in another program unit in the same source file. + +This diagnostic is designed to catch cases where a program +might depend on using the name @var{intrinsic} as an intrinsic +in one program unit and as a global name (such as the name +of a subroutine or function) in another, but @code{g77} recognizes +the name as an intrinsic in both cases. + +After verifying that the program unit making implicit use +of the intrinsic is indeed written expecting the intrinsic, +add an @samp{INTRINSIC @var{intrinsic}} statement to that +program unit to prevent this warning. + +This and related warnings are disabled by using +the @samp{-Wno-globals} option when compiling. + +Note that this warning is not issued for standard intrinsics. +Standard intrinsics include those described in the FORTRAN 77 +standard and, if @samp{-ff90} is specified, those described +in the Fortran 90 standard. +Such intrinsics are not as likely to be confused with user +procedures as intrinsics provided as extensions to the +standard by @code{g77}. + +@node INTGLOB +@section @code{INTGLOB} + +@noindent +@smallexample +Same name `@var{intrinsic}' given @dots{} +@end smallexample + +The name @var{intrinsic} is used for a global entity (a common +block or a program unit) in one program unit and implicitly +used as an intrinsic in another program unit. + +This diagnostic is designed to catch cases where a program +intends to use a name entirely as a global name, but @code{g77} +recognizes the name as an intrinsic in the program unit that +references the name, a situation that would likely produce +incorrect code. + +For example: + +@smallexample +INTEGER FUNCTION TIME() +@dots{} +END +@dots{} +PROGRAM SAMP +INTEGER TIME +PRINT *, 'Time is ', TIME() +END +@end smallexample + +The above example defines a program unit named @samp{TIME}, but +the reference to @samp{TIME} in the main program unit @samp{SAMP} +is normally treated by @code{g77} as a reference to the intrinsic +@code{TIME()} (unless a command-line option that prevents such +treatment has been specified). + +As a result, the program @samp{SAMP} will @emph{not} +invoke the @samp{TIME} function in the same source file. + +Since @code{g77} recognizes @code{libU77} procedures as +intrinsics, and since some existing code uses the same names +for its own procedures as used by some @code{libU77} +procedures, this situation is expected to arise often enough +to make this sort of warning worth issuing. + +After verifying that the program unit making implicit use +of the intrinsic is indeed written expecting the intrinsic, +add an @samp{INTRINSIC @var{intrinsic}} statement to that +program unit to prevent this warning. + +Or, if you believe the program unit is designed to invoke the +program-defined procedure instead of the intrinsic (as +recognized by @code{g77}), add an @samp{EXTERNAL @var{intrinsic}} +statement to the program unit that references the name to +prevent this warning. + +This and related warnings are disabled by using +the @samp{-Wno-globals} option when compiling. + +Note that this warning is not issued for standard intrinsics. +Standard intrinsics include those described in the FORTRAN 77 +standard and, if @samp{-ff90} is specified, those described +in the Fortran 90 standard. +Such intrinsics are not as likely to be confused with user +procedures as intrinsics provided as extensions to the +standard by @code{g77}. + +@node LEX +@section @code{LEX} + +@noindent +@smallexample +Unrecognized character @dots{} +Invalid first character @dots{} +Line too long @dots{} +Non-numeric character @dots{} +Continuation indicator @dots{} +Label at @dots{} invalid with continuation line indicator @dots{} +Character constant @dots{} +Continuation line @dots{} +Statement at @dots{} begins with invalid token +@end smallexample + +Although the diagnostics identify specific problems, they can +be produced when general problems such as the following occur: + +@itemize @bullet +@item +The source file contains something other than Fortran code. + +If the code in the file does not look like many of the examples +elsewhere in this document, it might not be Fortran code. +(Note that Fortran code often is written in lower case letters, +while the examples in this document use upper case letters, +for stylistic reasons.) + +For example, if the file contains lots of strange-looking +characters, it might be APL source code; if it contains lots +of parentheses, it might be Lisp source code; if it +contains lots of bugs, it might be C++ source code. + +@item +The source file contains free-form Fortran code, but @samp{-ffree-form} +was not specified on the command line to compile it. + +Free form is a newer form for Fortran code. +The older, classic form is called fixed form. + +Fixed-form code is visually fairly distinctive, because +numerical labels and comments are all that appear in +the first five columns of a line, the sixth column is +reserved to denote continuation lines, +and actual statements start at or beyond column 7. +Spaces generally are not significant, so if you +see statements such as @samp{REALX,Y} and @samp{DO10I=1,100}, +you are looking at fixed-form code. +Comment lines are indicated by the letter @samp{C} or the symbol +@samp{*} in column 1. +(Some code uses @samp{!} or @samp{/*} to begin in-line comments, +which many compilers support.) + +Free-form code is distinguished from fixed-form source +primarily by the fact that statements may start anywhere. +(If lots of statements start in columns 1 through 6, +that's a strong indicator of free-form source.) +Consecutive keywords must be separated by spaces, so +@samp{REALX,Y} is not valid, while @samp{REAL X,Y} is. +There are no comment lines per se, but @samp{!} starts a +comment anywhere in a line (other than within a character or +hollerith constant). + +@xref{Source Form}, for more information. + +@item +The source file is in fixed form and has been edited without +sensitivity to the column requirements. + +Statements in fixed-form code must be entirely contained within +columns 7 through 72 on a given line. +Starting them ``early'' is more likely to result in diagnostics +than finishing them ``late'', though both kinds of errors are +often caught at compile time. + +For example, if the following code fragment is edited by following +the commented instructions literally, the result, shown afterward, +would produce a diagnostic when compiled: + +@smallexample +C On XYZZY systems, remove "C" on next line: +C CALL XYZZY_RESET +@end smallexample + +The result of editing the above line might be: + +@smallexample +C On XYZZY systems, remove "C" on next line: + CALL XYZZY_RESET +@end smallexample + +However, that leaves the first @samp{C} in the @samp{CALL} +statement in column 6, making it a comment line, which is +not really what the author intended, and which is likely +to result in one of the above-listed diagnostics. + +@emph{Replacing} the @samp{C} in column 1 with a space +is the proper change to make, to ensure the @samp{CALL} +keyword starts in or after column 7. + +Another common mistake like this is to forget that fixed-form +source lines are significant through only column 72, and that, +normally, any text beyond column 72 is ignored or is diagnosed +at compile time. + +@xref{Source Form}, for more information. + +@item +The source file requires preprocessing, and the preprocessing +is not being specified at compile time. + +A source file containing lines beginning with @code{#define}, +@code{#include}, @code{#if}, and so on is likely one that +requires preprocessing. + +If the file's suffix is @samp{.f} or @samp{.for}, the file +will normally be compiled @emph{without} preprocessing by @code{g77}. + +Change the file's suffix from @samp{.f} to @samp{.F} (or, on +systems with case-insensitive file names, to @samp{.fpp}) or +from @samp{.for} to @samp{.fpp}. +@code{g77} compiles files with such names @emph{with} +preprocessing. + +Or, learn how to use @code{gcc}'s @samp{-x} option to specify +the language @samp{f77-cpp-input} for Fortran files that +require preprocessing. +@xref{Overall Options,,gcc,Using and Porting GNU CC}. + +@item +The source file is preprocessed, and the results of preprocessing +result in syntactic errors that are not necessarily obvious to +someone examining the source file itself. + +Examples of errors resulting from preprocessor macro expansion +include exceeding the line-length limit, improperly starting, +terminating, or incorporating the apostrophe or double-quote in +a character constant, improperly forming a hollerith constant, +and so on. + +@xref{Overall Options,,Options Controlling the Kind of Output}, +for suggestions about how to use, and not use, preprocessing +for Fortran code. +@end itemize + +@node GLOBALS +@section @code{GLOBALS} + +@noindent +@smallexample +Global name @var{name} defined at @dots{} already defined@dots{} +Global name @var{name} at @dots{} has different type@dots{} +Too many arguments passed to @var{name} at @dots{} +Too few arguments passed to @var{name} at @dots{} +Argument #@var{n} of @var{name} is @dots{} +@end smallexample + +These messages all identify disagreements about the +global procedure named @var{name} among different program +units (usually including @var{name} itself). + +These disagreements, if not diagnosed, could result in a +compiler crash if the compiler attempted to inline a reference +to @var{name} within a calling program unit that disagreed +with the @var{name} program unit regarding whether the +procedure is a subroutine or function, the type of the +return value of the procedure (if it is a function), the +number of arguments the procedure accepts, or the type +of each argument. + +Such disagreements @emph{should} be fixed in the Fortran +code itself. +However, if that is not immediately practical, and the code +has been working for some time, it is possible it will work +when compiled by @code{g77} with the @samp{-fno-globals} option. + +The @samp{-fno-globals} option disables these diagnostics, and +also disables all inlining of references to global procedures +to avoid compiler crashes. +The diagnostics are actually produced, but as warnings, unless +the @samp{-Wno-globals} option also is specified. + +After using @samp{-fno-globals} to work around these problems, +it is wise to stop using that option and address them by fixing +the Fortran code, because such problems, while they might not +actually result in bugs on some systems, indicate that the code +is not as portable as it could be. +In particular, the code might appear to work on a particular +system, but have bugs that affect the reliability of the data +without exhibiting any other outward manifestations of the bugs. + +@end ifset + +@node Index +@unnumbered Index + +@printindex cp +@summarycontents +@contents +@bye diff --git a/gcc/f/gbe/2.7.2.2.diff b/gcc/f/gbe/2.7.2.2.diff new file mode 100644 index 000000000000..e99ba671741d --- /dev/null +++ b/gcc/f/gbe/2.7.2.2.diff @@ -0,0 +1,11296 @@ +IMPORTANT: After applying this patch, you must rebuild the +Info documentation derived from the Texinfo files in the +gcc distribution, as this patch does not include patches +to any derived files (due to differences in the way gcc +version 2.7.2.2 is obtained by users). Use the following +command sequence after applying this patch: + + cd gcc-2.7.2.2; make -f Makefile.in gcc.info + +If that fails due to `makeinfo' not being installed, obtain +texinfo-3.11.tar.gz from a GNU distribution site, unpack, +build, and install it, and try the above command sequence +again. + + +diff -rcp2N gcc-2.7.2.2/ChangeLog g77-new/ChangeLog +*** gcc-2.7.2.2/ChangeLog Thu Feb 20 19:24:10 1997 +--- g77-new/ChangeLog Mon Aug 11 06:48:02 1997 +*************** +*** 1,2 **** +--- 1,244 ---- ++ Sun Aug 10 18:14:24 1997 Craig Burley ++ ++ Integrate C front end part of patch for better alias ++ handling from John Carr : ++ * c-decl.c (grokdeclarator): Check for RID_RESTRICT ++ flag; diagnose certain misuses; set DECL_RESTRICT as ++ appropriate. ++ * c-lex.c (init_lex): Set up RID_RESTRICT pointer. ++ Unset `restrict' as reserved word. ++ * c-lex.h: Replace RID_NOALIAS with RID_RESTRICT. ++ * c-parse.gperf: Add `restrict' and `__restrict' ++ keywords. ++ * tree.h: Add DECL_RESTRICT flag. ++ ++ Sun Aug 10 14:50:30 1997 Jim Wilson ++ ++ * sdbout.c (plain_type_1, case ARRAY_TYPE): Verify that TYPE_DOMAIN ++ has integer TYPE_{MAX,MIN}_VALUE before using them. ++ ++ Mon Jul 28 15:35:38 1997 Craig Burley ++ ++ * combine.c (num_sign_bit_copies): Speed up the 961126-1.c ++ case of repeated (neg (neg (neg ...))) so c-torture runs ++ in less time. ++ ++ * reload.c (find_reloads_toplev, find_reloads_address): ++ These now return whether replacement by a constant, so ++ caller can know to do other replacements. Currently if ++ caller doesn't want that info and such replacement would ++ happen, we crash so as to investigate the problem and ++ learn more about it. All callers updated. ++ (find_reloads): If pseudo replaced by constant, always ++ update duplicates of it. ++ ++ Mon Jul 21 00:00:24 1997 Craig Burley ++ ++ * fold-const.c (size_binop): Make sure overflows ++ are flagged properly, so as to avoid silently generating ++ bad code for, e.g., a too-large array. ++ ++ Sun Jul 13 22:23:14 1997 Craig Burley ++ ++ * stmt.c (expand_expr_stmt): Must generate code for ++ statements within an expression (gcc's `({ ... )}') ++ even if -fsyntax-only. ++ ++ Mon Jun 30 17:23:07 1997 Michael Meissner ++ ++ * gcc.c (process_command): If -save-temps and -pipe were specified ++ together, don't do -pipe. ++ ++ Thu Jun 26 05:40:46 1997 Craig Burley ++ ++ * stor-layout.c (get_best_mode): Handle negative bitpos ++ correctly, so caller doesn't get into infinite recursion ++ trying to cope with a spurious VOIDmode. ++ ++ Tue Jun 24 19:46:31 1997 Craig Burley ++ ++ * varasm.c (assemble_variable): If low part of size ++ doesn't fit in an int, variable is too large. ++ ++ Sat Jun 21 12:09:00 1997 Craig Burley ++ ++ * toplev.c (rest_of_compilation): Also temporarily set ++ flag_unroll_all_loops to 0 during first of two calls ++ to loop_optimize, and clean up code a bit to make it ++ easier to read. ++ ++ * expr.c (safe_from_p_1, safe_from_p): Fix these to use ++ TREE_SET_CODE instead of TREE_CODE. ++ ++ Thu Jun 19 19:30:47 1997 Craig Burley ++ ++ * config/alpha/alpha.c: Don't include on ++ GNU Linux machines. ++ ++ * config/alpha/elf.c: New file for ELF systems. ++ ++ * config/alpha/xm-alpha.h: Don't declare alloca() ++ if it's already a macro (probably defined in stdlib.h). ++ ++ * config/alpha/xm-linux.h (HAVE_STRERROR): #define ++ this, according to what various people suggest. ++ ++ * config.guess, configure: Make some (hopefully safe) ++ changes, based mostly on gcc-2.8.0-in-development, ++ in the hopes that these make some systems configure ++ "out of the box" more easily, especially Alpha systems. ++ ++ Mon Jun 9 04:26:53 1997 Craig Burley ++ ++ * expr.c (safe_from_p): Don't examine a given SAVE_EXPR ++ node more than once, to avoid combinatorial explosion ++ in complex expressions. Fortran case that triggered ++ this had a complicated *and* complex expression with ++ 293 unique nodes, resulting in 28 minutes of compile ++ time mostly spent in a single top-level safe_from_p() ++ call due to all the redundant SAVE_EXPR traversals. ++ This change reduced the time to around 2 seconds. ++ (safe_from_p_1): New helper function that does almost ++ exactly what the old safe_from_p() did. ++ ++ Sun May 18 21:18:48 1997 Craig Burley ++ ++ * fold-const.c (fold): Clarify why TRUNC_DIV_EXPR ++ and FLOOR_DIV_EXPR aren't rewritten to EXACT_DIV_EXPR, ++ clean up related code. ++ ++ Sat May 3 13:53:00 1997 Craig Burley ++ ++ * config.sub: Change all `i[345]' to `i[3456]' to ++ support Pentium Pro (this change was already made ++ in configure for gcc-2.7.2.2). ++ ++ From Toon Moene : ++ * toplev.c (rest_of_compilation): Unroll loops ++ only the final time through loop optimization. ++ ++ Sun Apr 20 10:45:35 1997 Richard Kenner ++ ++ * final.c (profile_function): Only call ASM_OUTPUT_REG_{PUSH,POP} ++ if defined. ++ ++ Wed Apr 16 22:26:16 1997 Craig Burley ++ ++ * alias.c, cse.c, loop.c, rtl.c, rtl.h, sched.c: ++ Make changes submitted by . ++ ++ Sun Apr 13 19:32:53 1997 Craig Burley ++ ++ * fold-const.c (fold): If extra warnings enabled, ++ warn about integer division by zero. ++ ++ Sun Apr 13 08:15:31 1997 Bernd Schmidt ++ ++ * final.c (profile_function): Save the static chain register ++ around the call to the profiler function. ++ ++ Sat Apr 12 14:56:42 1997 Craig Burley ++ ++ * unroll.c (find_splittable_givs): Permit more cases ++ of mult_val/add_val to agree by using rtx_equal_p ++ to compare them instead of requiring them to be ++ integers with the same value. Also don't bother ++ checking if ADDRESS_COST not defined (they will be ++ equal in that case). ++ ++ Fri Apr 11 03:30:04 1997 Craig Burley ++ ++ * unroll.c (find_splittable_givs): Must create a new ++ register if the mult_val and add_val fields don't ++ agree. ++ ++ Fri Apr 4 23:00:55 1997 Craig Burley ++ ++ * fold-const.c (fold): Don't call multiple_of_p if ++ arg1 is constant zero, to avoid crashing; simplify ++ code accordingly. ++ ++ Wed Feb 26 13:09:33 1997 Michael Meissner ++ ++ * reload.c (debug_reload): Fix format string to print ++ reload_nocombine[r]. ++ ++ Sun Feb 23 15:26:53 1997 Craig Burley ++ ++ * fold-const.c (multiple_of_p): Clean up and improve. ++ (fold): Clean up invocation of multiple_of_p. ++ ++ Sat Feb 8 04:53:27 1997 Craig Burley ++ ++ From Fri, 07 Feb 1997 22:02:21 -0500: ++ * alias.c (init_alias_analysis): Reduce amount of time ++ needed to simplify the reg_base_value array in the ++ typical case (especially involving function inlining). ++ ++ Fri Jan 10 17:22:17 1997 Craig Burley ++ ++ Minor improvements/fixes to better alias handling: ++ * Makefile.in (alias.o): Fix typo in rule (was RLT_H). ++ * cse.c, sched.c: Fix up some indenting. ++ * toplev.c: Add -fargument-alias flag, so Fortran users ++ can turn C-style aliasing on once g77 defaults to ++ -fargument-noalias-global. ++ ++ Integrate patch for better alias handling from ++ John Carr : ++ * Makefile.in (OBJS, alias.o): New module and rule. ++ * alias.c: New source module. ++ * calls.c (expand_call): Recognize alias status of calls ++ to malloc(). ++ * combine.c (distribute_notes): New REG_NOALIAS note. ++ * rtl.h (REG_NOALIAS): Ditto. ++ Many other changes for new alias.c module. ++ * cse.c: Many changes, and much code moved into alias.c. ++ * flags.h (flag_alias_check, flag_argument_noalias): ++ New flags. ++ * toplev.c: New flags and related options. ++ * local-alloc.c (validate_equiv_mem_from_store): ++ Caller of true_dependence changed. ++ * loop.c (NUM_STORES): Increase to 50 from 20. ++ (prescan_loop): "const" functions don't alter unknown addresses. ++ (invariant_p): Caller of true_dependence changed. ++ (record_giv): Zero new unrolled and shared flags. ++ (emit_iv_add_mult): Record base value for register. ++ * sched.c: Many changes, mostly moving code to alias.c. ++ (sched_note_set): SCHED_SORT macro def form, but not function, ++ inexplicably changed. ++ * unroll.c: Record base values for registers, etc. ++ ++ Fri Jan 3 04:01:00 1997 Craig Burley ++ ++ * loop.c (check_final_value): Handle insns with no luid's ++ appropriately, instead of crashing on INSN_LUID macro ++ invocations. ++ ++ Mon Dec 23 00:49:19 1996 Craig Burley ++ ++ * config/alpha/alpha.md: Fix pattern that matches if_then_else ++ involving DF target, DF comparison, SF source. ++ ++ Fri Dec 20 15:42:52 1996 Craig Burley ++ ++ * fold-const.c (multiple_of_p): New function. ++ (fold): Use new function to turn *_DIV_EXPR into EXACT_DIV_EXPR. ++ ++ Tue Oct 22 18:32:20 1996 Jim Wilson ++ ++ * unroll.c (unroll_loop): Always reject loops with unbalanced blocks. ++ ++ Tue Sep 24 19:37:00 1996 Jim Wilson ++ ++ * reload.c (push_secondary_reload): Do strip paradoxical SUBREG ++ even if reload_class is CLASS_CANNOT_CHANGE_SIZE. Change reload_mode ++ to mode in SECONDARY_MEMORY_NEEDED and get_secondary_mem calls. ++ ++ Mon Aug 5 16:53:36 1996 Doug Evans ++ ++ * stor-layout.c (layout_record): Correct overflow test for 0 sized ++ fields. ++ + Sat Jun 29 12:33:39 1996 Richard Kenner + +*************** Tue Jun 11 20:18:03 1996 Per Bothner ++ ++ * unroll.c (copy_loop_body): When update split DEST_ADDR giv, ++ check to make sure it was split. ++ (find_splittable_givs): Fix reversed test of verify_addresses result. ++ + Fri May 10 18:35:00 1996 Richard Kenner (kenner@vlsi1.ultra.nyu.edu) + +*************** Mon Feb 19 07:35:07 1996 Torbjorn Granl +*** 66,69 **** +--- 314,322 ---- + * rs6000.md (not:SI with assign and compare): Fix typo. + ++ Tue Feb 13 17:43:46 1996 Jim Wilson ++ ++ * integrate.c (save_constants_in_decl_trees): New function. ++ (save_for_inline_copying, save_for_inline_nocopy): Call it. ++ + Wed Jan 24 18:00:12 1996 Brendan Kehoe + +*************** Tue Jan 16 06:01:28 1996 Thomas Graiche +*** 81,88 **** +--- 334,357 ---- + * i386/freebsd.h (ASM_WEAKEN_LABEL): Deleted; not supported. + ++ Mon Jan 15 07:22:59 1996 Michel Delval (mfd@ccv.fr) ++ ++ * reload.c (find_equiv_reg): Apply single_set, not PATTERN, to WHERE. ++ + Sun Jan 7 17:11:11 1996 David Edelsohn + + * collect2.c (scan_libraries): Correct Import File ID interpretation. + ++ Mon Jan 1 09:05:07 1996 Richard Kenner (kenner@vlsi1.ultra.nyu.edu) ++ ++ * local-alloc.c (reg_equiv_replacement): New variable. ++ (memref_referenced_p, case REG): Check for reg_equiv_replacement. ++ (update_equiv_regs): reg_equiv_replacement now file-scope. ++ ++ Fri Dec 22 17:29:42 1995 Richard Kenner (kenner@vlsi1.ultra.nyu.edu) ++ ++ * reload.c (find_valid_class): New function. ++ (push_reload): Use it in cases where a SUBREG and its contents ++ both need to be reloaded. ++ + Thu Dec 28 22:24:53 1995 Michael Meissner + +*************** Mon Dec 18 18:40:34 1995 Jim Wilson ++ ++ * rs6000/rs6000.c (input_operand): Allow any integer constant, not ++ just integers that fit in 1 instruction. + + Sun Nov 26 14:47:42 1995 Richard Kenner +diff -rcp2N gcc-2.7.2.2/Makefile.in g77-new/Makefile.in +*** gcc-2.7.2.2/Makefile.in Sun Nov 26 14:44:25 1995 +--- g77-new/Makefile.in Sun Aug 10 18:46:06 1997 +*************** OBJS = toplev.o version.o tree.o print-t +*** 519,523 **** + integrate.o jump.o cse.o loop.o unroll.o flow.o stupid.o combine.o \ + regclass.o local-alloc.o global.o reload.o reload1.o caller-save.o \ +! insn-peep.o reorg.o sched.o final.o recog.o reg-stack.o \ + insn-opinit.o insn-recog.o insn-extract.o insn-output.o insn-emit.o \ + insn-attrtab.o $(out_object_file) getpwd.o convert.o $(EXTRA_OBJS) +--- 519,523 ---- + integrate.o jump.o cse.o loop.o unroll.o flow.o stupid.o combine.o \ + regclass.o local-alloc.o global.o reload.o reload1.o caller-save.o \ +! insn-peep.o reorg.o alias.o sched.o final.o recog.o reg-stack.o \ + insn-opinit.o insn-recog.o insn-extract.o insn-output.o insn-emit.o \ + insn-attrtab.o $(out_object_file) getpwd.o convert.o $(EXTRA_OBJS) +*************** LIB2FUNCS = _muldi3 _divdi3 _moddi3 _udi +*** 570,574 **** + _fixxfdi _fixunsxfdi _floatdixf _fixunsxfsi \ + _fixtfdi _fixunstfdi _floatditf \ +! __gcc_bcmp _varargs _eprintf _op_new _op_vnew _new_handler _op_delete \ + _op_vdel _bb _shtab _clear_cache _trampoline __main _exit _ctors _eh \ + _pure +--- 570,575 ---- + _fixxfdi _fixunsxfdi _floatdixf _fixunsxfsi \ + _fixtfdi _fixunstfdi _floatditf \ +! __gcc_bcmp _varargs __dummy _eprintf \ +! _op_new _op_vnew _new_handler _op_delete \ + _op_vdel _bb _shtab _clear_cache _trampoline __main _exit _ctors _eh \ + _pure +*************** expr.o : expr.c $(CONFIG_H) $(RTL_H) $(T +*** 1179,1183 **** + insn-flags.h insn-codes.h expr.h insn-config.h recog.h output.h \ + typeclass.h bytecode.h bc-opcode.h bc-typecd.h bc-typecd.def bc-optab.h \ +! bc-emit.h modemap.def + calls.o : calls.c $(CONFIG_H) $(RTL_H) $(TREE_H) flags.h expr.h insn-codes.h \ + insn-flags.h +--- 1180,1184 ---- + insn-flags.h insn-codes.h expr.h insn-config.h recog.h output.h \ + typeclass.h bytecode.h bc-opcode.h bc-typecd.h bc-typecd.def bc-optab.h \ +! bc-emit.h modemap.def hard-reg-set.h + calls.o : calls.c $(CONFIG_H) $(RTL_H) $(TREE_H) flags.h expr.h insn-codes.h \ + insn-flags.h +*************** reorg.o : reorg.c $(CONFIG_H) $(RTL_H) c +*** 1238,1241 **** +--- 1239,1243 ---- + basic-block.h regs.h insn-config.h insn-attr.h insn-flags.h recog.h \ + flags.h output.h ++ alias.o : $(CONFIG_H) $(RTL_H) flags.h hard-reg-set.h regs.h + sched.o : sched.c $(CONFIG_H) $(RTL_H) basic-block.h regs.h hard-reg-set.h \ + flags.h insn-config.h insn-attr.h +diff -rcp2N gcc-2.7.2.2/alias.c g77-new/alias.c +*** gcc-2.7.2.2/alias.c Wed Dec 31 19:00:00 1969 +--- g77-new/alias.c Thu Jul 10 20:08:43 1997 +*************** +*** 0 **** +--- 1,996 ---- ++ /* Alias analysis for GNU C, by John Carr (jfc@mit.edu). ++ Derived in part from sched.c */ ++ #include "config.h" ++ #include "rtl.h" ++ #include "expr.h" ++ #include "regs.h" ++ #include "hard-reg-set.h" ++ #include "flags.h" ++ ++ static rtx canon_rtx PROTO((rtx)); ++ static int rtx_equal_for_memref_p PROTO((rtx, rtx)); ++ static rtx find_symbolic_term PROTO((rtx)); ++ static int memrefs_conflict_p PROTO((int, rtx, int, rtx, ++ HOST_WIDE_INT)); ++ ++ /* Set up all info needed to perform alias analysis on memory references. */ ++ ++ #define SIZE_FOR_MODE(X) (GET_MODE_SIZE (GET_MODE (X))) ++ ++ /* reg_base_value[N] gives an address to which register N is related. ++ If all sets after the first add or subtract to the current value ++ or otherwise modify it so it does not point to a different top level ++ object, reg_base_value[N] is equal to the address part of the source ++ of the first set. The value will be a SYMBOL_REF, a LABEL_REF, or ++ (address (reg)) to indicate that the address is derived from an ++ argument or fixed register. */ ++ rtx *reg_base_value; ++ unsigned int reg_base_value_size; /* size of reg_base_value array */ ++ #define REG_BASE_VALUE(X) \ ++ (REGNO (X) < reg_base_value_size ? reg_base_value[REGNO (X)] : 0) ++ ++ /* Vector indexed by N giving the initial (unchanging) value known ++ for pseudo-register N. */ ++ rtx *reg_known_value; ++ ++ /* Indicates number of valid entries in reg_known_value. */ ++ static int reg_known_value_size; ++ ++ /* Vector recording for each reg_known_value whether it is due to a ++ REG_EQUIV note. Future passes (viz., reload) may replace the ++ pseudo with the equivalent expression and so we account for the ++ dependences that would be introduced if that happens. */ ++ /* ??? This is a problem only on the Convex. The REG_EQUIV notes created in ++ assign_parms mention the arg pointer, and there are explicit insns in the ++ RTL that modify the arg pointer. Thus we must ensure that such insns don't ++ get scheduled across each other because that would invalidate the REG_EQUIV ++ notes. One could argue that the REG_EQUIV notes are wrong, but solving ++ the problem in the scheduler will likely give better code, so we do it ++ here. */ ++ char *reg_known_equiv_p; ++ ++ /* Inside SRC, the source of a SET, find a base address. */ ++ ++ /* When copying arguments into pseudo-registers, record the (ADDRESS) ++ expression for the argument directly so that even if the argument ++ register is changed later (e.g. for a function call) the original ++ value is noted. */ ++ static int copying_arguments; ++ ++ static rtx ++ find_base_value (src) ++ register rtx src; ++ { ++ switch (GET_CODE (src)) ++ { ++ case SYMBOL_REF: ++ case LABEL_REF: ++ return src; ++ ++ case REG: ++ if (copying_arguments && REGNO (src) < FIRST_PSEUDO_REGISTER) ++ return reg_base_value[REGNO (src)]; ++ return src; ++ ++ case MEM: ++ /* Check for an argument passed in memory. Only record in the ++ copying-arguments block; it is too hard to track changes ++ otherwise. */ ++ if (copying_arguments ++ && (XEXP (src, 0) == arg_pointer_rtx ++ || (GET_CODE (XEXP (src, 0)) == PLUS ++ && XEXP (XEXP (src, 0), 0) == arg_pointer_rtx))) ++ return gen_rtx (ADDRESS, VOIDmode, src); ++ return 0; ++ ++ case CONST: ++ src = XEXP (src, 0); ++ if (GET_CODE (src) != PLUS && GET_CODE (src) != MINUS) ++ break; ++ /* fall through */ ++ case PLUS: ++ case MINUS: ++ /* Guess which operand to set the register equivalent to. */ ++ /* If the first operand is a symbol or the second operand is ++ an integer, the first operand is the base address. */ ++ if (GET_CODE (XEXP (src, 0)) == SYMBOL_REF ++ || GET_CODE (XEXP (src, 0)) == LABEL_REF ++ || GET_CODE (XEXP (src, 1)) == CONST_INT) ++ return XEXP (src, 0); ++ /* If an operand is a register marked as a pointer, it is the base. */ ++ if (GET_CODE (XEXP (src, 0)) == REG ++ && REGNO_POINTER_FLAG (REGNO (XEXP (src, 0)))) ++ src = XEXP (src, 0); ++ else if (GET_CODE (XEXP (src, 1)) == REG ++ && REGNO_POINTER_FLAG (REGNO (XEXP (src, 1)))) ++ src = XEXP (src, 1); ++ else ++ return 0; ++ if (copying_arguments && REGNO (src) < FIRST_PSEUDO_REGISTER) ++ return reg_base_value[REGNO (src)]; ++ return src; ++ ++ case AND: ++ /* If the second operand is constant set the base ++ address to the first operand. */ ++ if (GET_CODE (XEXP (src, 1)) == CONST_INT ++ && GET_CODE (XEXP (src, 0)) == REG) ++ { ++ src = XEXP (src, 0); ++ if (copying_arguments && REGNO (src) < FIRST_PSEUDO_REGISTER) ++ return reg_base_value[REGNO (src)]; ++ return src; ++ } ++ return 0; ++ ++ case HIGH: ++ return XEXP (src, 0); ++ } ++ ++ return 0; ++ } ++ ++ /* Called from init_alias_analysis indirectly through note_stores. */ ++ ++ /* while scanning insns to find base values, reg_seen[N] is nonzero if ++ register N has been set in this function. */ ++ static char *reg_seen; ++ ++ static ++ void record_set (dest, set) ++ rtx dest, set; ++ { ++ register int regno; ++ rtx src; ++ ++ if (GET_CODE (dest) != REG) ++ return; ++ ++ regno = REGNO (dest); ++ ++ if (set) ++ { ++ /* A CLOBBER wipes out any old value but does not prevent a previously ++ unset register from acquiring a base address (i.e. reg_seen is not ++ set). */ ++ if (GET_CODE (set) == CLOBBER) ++ { ++ reg_base_value[regno] = 0; ++ return; ++ } ++ src = SET_SRC (set); ++ } ++ else ++ { ++ static int unique_id; ++ if (reg_seen[regno]) ++ { ++ reg_base_value[regno] = 0; ++ return; ++ } ++ reg_seen[regno] = 1; ++ reg_base_value[regno] = gen_rtx (ADDRESS, Pmode, ++ GEN_INT (unique_id++)); ++ return; ++ } ++ ++ /* This is not the first set. If the new value is not related to the ++ old value, forget the base value. Note that the following code is ++ not detected: ++ extern int x, y; int *p = &x; p += (&y-&x); ++ ANSI C does not allow computing the difference of addresses ++ of distinct top level objects. */ ++ if (reg_base_value[regno]) ++ switch (GET_CODE (src)) ++ { ++ case PLUS: ++ case MINUS: ++ if (XEXP (src, 0) != dest && XEXP (src, 1) != dest) ++ reg_base_value[regno] = 0; ++ break; ++ case AND: ++ if (XEXP (src, 0) != dest || GET_CODE (XEXP (src, 1)) != CONST_INT) ++ reg_base_value[regno] = 0; ++ break; ++ case LO_SUM: ++ if (XEXP (src, 0) != dest) ++ reg_base_value[regno] = 0; ++ break; ++ default: ++ reg_base_value[regno] = 0; ++ break; ++ } ++ /* If this is the first set of a register, record the value. */ ++ else if ((regno >= FIRST_PSEUDO_REGISTER || ! fixed_regs[regno]) ++ && ! reg_seen[regno] && reg_base_value[regno] == 0) ++ reg_base_value[regno] = find_base_value (src); ++ ++ reg_seen[regno] = 1; ++ } ++ ++ /* Called from loop optimization when a new pseudo-register is created. */ ++ void ++ record_base_value (regno, val) ++ int regno; ++ rtx val; ++ { ++ if (!flag_alias_check || regno >= reg_base_value_size) ++ return; ++ if (GET_CODE (val) == REG) ++ { ++ if (REGNO (val) < reg_base_value_size) ++ reg_base_value[regno] = reg_base_value[REGNO (val)]; ++ return; ++ } ++ reg_base_value[regno] = find_base_value (val); ++ } ++ ++ static rtx ++ canon_rtx (x) ++ rtx x; ++ { ++ /* Recursively look for equivalences. */ ++ if (GET_CODE (x) == REG && REGNO (x) >= FIRST_PSEUDO_REGISTER ++ && REGNO (x) < reg_known_value_size) ++ return reg_known_value[REGNO (x)] == x ++ ? x : canon_rtx (reg_known_value[REGNO (x)]); ++ else if (GET_CODE (x) == PLUS) ++ { ++ rtx x0 = canon_rtx (XEXP (x, 0)); ++ rtx x1 = canon_rtx (XEXP (x, 1)); ++ ++ if (x0 != XEXP (x, 0) || x1 != XEXP (x, 1)) ++ { ++ /* We can tolerate LO_SUMs being offset here; these ++ rtl are used for nothing other than comparisons. */ ++ if (GET_CODE (x0) == CONST_INT) ++ return plus_constant_for_output (x1, INTVAL (x0)); ++ else if (GET_CODE (x1) == CONST_INT) ++ return plus_constant_for_output (x0, INTVAL (x1)); ++ return gen_rtx (PLUS, GET_MODE (x), x0, x1); ++ } ++ } ++ /* This gives us much better alias analysis when called from ++ the loop optimizer. Note we want to leave the original ++ MEM alone, but need to return the canonicalized MEM with ++ all the flags with their original values. */ ++ else if (GET_CODE (x) == MEM) ++ { ++ rtx addr = canon_rtx (XEXP (x, 0)); ++ if (addr != XEXP (x, 0)) ++ { ++ rtx new = gen_rtx (MEM, GET_MODE (x), addr); ++ MEM_VOLATILE_P (new) = MEM_VOLATILE_P (x); ++ RTX_UNCHANGING_P (new) = RTX_UNCHANGING_P (x); ++ MEM_IN_STRUCT_P (new) = MEM_IN_STRUCT_P (x); ++ x = new; ++ } ++ } ++ return x; ++ } ++ ++ /* Return 1 if X and Y are identical-looking rtx's. ++ ++ We use the data in reg_known_value above to see if two registers with ++ different numbers are, in fact, equivalent. */ ++ ++ static int ++ rtx_equal_for_memref_p (x, y) ++ rtx x, y; ++ { ++ register int i; ++ register int j; ++ register enum rtx_code code; ++ register char *fmt; ++ ++ if (x == 0 && y == 0) ++ return 1; ++ if (x == 0 || y == 0) ++ return 0; ++ x = canon_rtx (x); ++ y = canon_rtx (y); ++ ++ if (x == y) ++ return 1; ++ ++ code = GET_CODE (x); ++ /* Rtx's of different codes cannot be equal. */ ++ if (code != GET_CODE (y)) ++ return 0; ++ ++ /* (MULT:SI x y) and (MULT:HI x y) are NOT equivalent. ++ (REG:SI x) and (REG:HI x) are NOT equivalent. */ ++ ++ if (GET_MODE (x) != GET_MODE (y)) ++ return 0; ++ ++ /* REG, LABEL_REF, and SYMBOL_REF can be compared nonrecursively. */ ++ ++ if (code == REG) ++ return REGNO (x) == REGNO (y); ++ if (code == LABEL_REF) ++ return XEXP (x, 0) == XEXP (y, 0); ++ if (code == SYMBOL_REF) ++ return XSTR (x, 0) == XSTR (y, 0); ++ ++ /* For commutative operations, the RTX match if the operand match in any ++ order. Also handle the simple binary and unary cases without a loop. */ ++ if (code == EQ || code == NE || GET_RTX_CLASS (code) == 'c') ++ return ((rtx_equal_for_memref_p (XEXP (x, 0), XEXP (y, 0)) ++ && rtx_equal_for_memref_p (XEXP (x, 1), XEXP (y, 1))) ++ || (rtx_equal_for_memref_p (XEXP (x, 0), XEXP (y, 1)) ++ && rtx_equal_for_memref_p (XEXP (x, 1), XEXP (y, 0)))); ++ else if (GET_RTX_CLASS (code) == '<' || GET_RTX_CLASS (code) == '2') ++ return (rtx_equal_for_memref_p (XEXP (x, 0), XEXP (y, 0)) ++ && rtx_equal_for_memref_p (XEXP (x, 1), XEXP (y, 1))); ++ else if (GET_RTX_CLASS (code) == '1') ++ return rtx_equal_for_memref_p (XEXP (x, 0), XEXP (y, 0)); ++ ++ /* Compare the elements. If any pair of corresponding elements ++ fail to match, return 0 for the whole things. */ ++ ++ fmt = GET_RTX_FORMAT (code); ++ for (i = GET_RTX_LENGTH (code) - 1; i >= 0; i--) ++ { ++ switch (fmt[i]) ++ { ++ case 'w': ++ if (XWINT (x, i) != XWINT (y, i)) ++ return 0; ++ break; ++ ++ case 'n': ++ case 'i': ++ if (XINT (x, i) != XINT (y, i)) ++ return 0; ++ break; ++ ++ case 'V': ++ case 'E': ++ /* Two vectors must have the same length. */ ++ if (XVECLEN (x, i) != XVECLEN (y, i)) ++ return 0; ++ ++ /* And the corresponding elements must match. */ ++ for (j = 0; j < XVECLEN (x, i); j++) ++ if (rtx_equal_for_memref_p (XVECEXP (x, i, j), XVECEXP (y, i, j)) == 0) ++ return 0; ++ break; ++ ++ case 'e': ++ if (rtx_equal_for_memref_p (XEXP (x, i), XEXP (y, i)) == 0) ++ return 0; ++ break; ++ ++ case 'S': ++ case 's': ++ if (strcmp (XSTR (x, i), XSTR (y, i))) ++ return 0; ++ break; ++ ++ case 'u': ++ /* These are just backpointers, so they don't matter. */ ++ break; ++ ++ case '0': ++ break; ++ ++ /* It is believed that rtx's at this level will never ++ contain anything but integers and other rtx's, ++ except for within LABEL_REFs and SYMBOL_REFs. */ ++ default: ++ abort (); ++ } ++ } ++ return 1; ++ } ++ ++ /* Given an rtx X, find a SYMBOL_REF or LABEL_REF within ++ X and return it, or return 0 if none found. */ ++ ++ static rtx ++ find_symbolic_term (x) ++ rtx x; ++ { ++ register int i; ++ register enum rtx_code code; ++ register char *fmt; ++ ++ code = GET_CODE (x); ++ if (code == SYMBOL_REF || code == LABEL_REF) ++ return x; ++ if (GET_RTX_CLASS (code) == 'o') ++ return 0; ++ ++ fmt = GET_RTX_FORMAT (code); ++ for (i = GET_RTX_LENGTH (code) - 1; i >= 0; i--) ++ { ++ rtx t; ++ ++ if (fmt[i] == 'e') ++ { ++ t = find_symbolic_term (XEXP (x, i)); ++ if (t != 0) ++ return t; ++ } ++ else if (fmt[i] == 'E') ++ break; ++ } ++ return 0; ++ } ++ ++ static rtx ++ find_base_term (x) ++ register rtx x; ++ { ++ switch (GET_CODE (x)) ++ { ++ case REG: ++ return REG_BASE_VALUE (x); ++ ++ case HIGH: ++ return find_base_term (XEXP (x, 0)); ++ ++ case CONST: ++ x = XEXP (x, 0); ++ if (GET_CODE (x) != PLUS && GET_CODE (x) != MINUS) ++ return 0; ++ /* fall through */ ++ case LO_SUM: ++ case PLUS: ++ case MINUS: ++ { ++ rtx tmp = find_base_term (XEXP (x, 0)); ++ if (tmp) ++ return tmp; ++ return find_base_term (XEXP (x, 1)); ++ } ++ ++ case AND: ++ if (GET_CODE (XEXP (x, 0)) == REG && GET_CODE (XEXP (x, 1)) == CONST_INT) ++ return REG_BASE_VALUE (XEXP (x, 0)); ++ return 0; ++ ++ case SYMBOL_REF: ++ case LABEL_REF: ++ return x; ++ ++ default: ++ return 0; ++ } ++ } ++ ++ /* Return 0 if the addresses X and Y are known to point to different ++ objects, 1 if they might be pointers to the same object. */ ++ ++ static int ++ base_alias_check (x, y) ++ rtx x, y; ++ { ++ rtx x_base = find_base_term (x); ++ rtx y_base = find_base_term (y); ++ ++ /* If either base address is unknown or the base addresses are equal, ++ nothing is known about aliasing. */ ++ ++ if (x_base == 0 || y_base == 0 || rtx_equal_p (x_base, y_base)) ++ return 1; ++ ++ /* The base addresses of the read and write are different ++ expressions. If they are both symbols there is no ++ conflict. */ ++ if (GET_CODE (x_base) != ADDRESS && GET_CODE (y_base) != ADDRESS) ++ return 0; ++ ++ /* If one address is a stack reference there can be no alias: ++ stack references using different base registers do not alias, ++ a stack reference can not alias a parameter, and a stack reference ++ can not alias a global. */ ++ if ((GET_CODE (x_base) == ADDRESS && GET_MODE (x_base) == Pmode) ++ || (GET_CODE (y_base) == ADDRESS && GET_MODE (y_base) == Pmode)) ++ return 0; ++ ++ if (! flag_argument_noalias) ++ return 1; ++ ++ if (flag_argument_noalias > 1) ++ return 0; ++ ++ /* Weak noalias assertion (arguments are distinct, but may match globals). */ ++ return ! (GET_MODE (x_base) == VOIDmode && GET_MODE (y_base) == VOIDmode); ++ } ++ ++ /* Return nonzero if X and Y (memory addresses) could reference the ++ same location in memory. C is an offset accumulator. When ++ C is nonzero, we are testing aliases between X and Y + C. ++ XSIZE is the size in bytes of the X reference, ++ similarly YSIZE is the size in bytes for Y. ++ ++ If XSIZE or YSIZE is zero, we do not know the amount of memory being ++ referenced (the reference was BLKmode), so make the most pessimistic ++ assumptions. ++ ++ We recognize the following cases of non-conflicting memory: ++ ++ (1) addresses involving the frame pointer cannot conflict ++ with addresses involving static variables. ++ (2) static variables with different addresses cannot conflict. ++ ++ Nice to notice that varying addresses cannot conflict with fp if no ++ local variables had their addresses taken, but that's too hard now. */ ++ ++ ++ static int ++ memrefs_conflict_p (xsize, x, ysize, y, c) ++ register rtx x, y; ++ int xsize, ysize; ++ HOST_WIDE_INT c; ++ { ++ if (GET_CODE (x) == HIGH) ++ x = XEXP (x, 0); ++ else if (GET_CODE (x) == LO_SUM) ++ x = XEXP (x, 1); ++ else ++ x = canon_rtx (x); ++ if (GET_CODE (y) == HIGH) ++ y = XEXP (y, 0); ++ else if (GET_CODE (y) == LO_SUM) ++ y = XEXP (y, 1); ++ else ++ y = canon_rtx (y); ++ ++ if (rtx_equal_for_memref_p (x, y)) ++ { ++ if (xsize == 0 || ysize == 0) ++ return 1; ++ if (c >= 0 && xsize > c) ++ return 1; ++ if (c < 0 && ysize+c > 0) ++ return 1; ++ return 0; ++ } ++ ++ if (y == frame_pointer_rtx || y == hard_frame_pointer_rtx ++ || y == stack_pointer_rtx) ++ { ++ rtx t = y; ++ int tsize = ysize; ++ y = x; ysize = xsize; ++ x = t; xsize = tsize; ++ } ++ ++ if (x == frame_pointer_rtx || x == hard_frame_pointer_rtx ++ || x == stack_pointer_rtx) ++ { ++ rtx y1; ++ ++ if (CONSTANT_P (y)) ++ return 0; ++ ++ if (GET_CODE (y) == PLUS ++ && canon_rtx (XEXP (y, 0)) == x ++ && (y1 = canon_rtx (XEXP (y, 1))) ++ && GET_CODE (y1) == CONST_INT) ++ { ++ c += INTVAL (y1); ++ return (xsize == 0 || ysize == 0 ++ || (c >= 0 && xsize > c) || (c < 0 && ysize+c > 0)); ++ } ++ ++ if (GET_CODE (y) == PLUS ++ && (y1 = canon_rtx (XEXP (y, 0))) ++ && CONSTANT_P (y1)) ++ return 0; ++ ++ return 1; ++ } ++ ++ if (GET_CODE (x) == PLUS) ++ { ++ /* The fact that X is canonicalized means that this ++ PLUS rtx is canonicalized. */ ++ rtx x0 = XEXP (x, 0); ++ rtx x1 = XEXP (x, 1); ++ ++ if (GET_CODE (y) == PLUS) ++ { ++ /* The fact that Y is canonicalized means that this ++ PLUS rtx is canonicalized. */ ++ rtx y0 = XEXP (y, 0); ++ rtx y1 = XEXP (y, 1); ++ ++ if (rtx_equal_for_memref_p (x1, y1)) ++ return memrefs_conflict_p (xsize, x0, ysize, y0, c); ++ if (rtx_equal_for_memref_p (x0, y0)) ++ return memrefs_conflict_p (xsize, x1, ysize, y1, c); ++ if (GET_CODE (x1) == CONST_INT) ++ if (GET_CODE (y1) == CONST_INT) ++ return memrefs_conflict_p (xsize, x0, ysize, y0, ++ c - INTVAL (x1) + INTVAL (y1)); ++ else ++ return memrefs_conflict_p (xsize, x0, ysize, y, c - INTVAL (x1)); ++ else if (GET_CODE (y1) == CONST_INT) ++ return memrefs_conflict_p (xsize, x, ysize, y0, c + INTVAL (y1)); ++ ++ /* Handle case where we cannot understand iteration operators, ++ but we notice that the base addresses are distinct objects. */ ++ /* ??? Is this still necessary? */ ++ x = find_symbolic_term (x); ++ if (x == 0) ++ return 1; ++ y = find_symbolic_term (y); ++ if (y == 0) ++ return 1; ++ return rtx_equal_for_memref_p (x, y); ++ } ++ else if (GET_CODE (x1) == CONST_INT) ++ return memrefs_conflict_p (xsize, x0, ysize, y, c - INTVAL (x1)); ++ } ++ else if (GET_CODE (y) == PLUS) ++ { ++ /* The fact that Y is canonicalized means that this ++ PLUS rtx is canonicalized. */ ++ rtx y0 = XEXP (y, 0); ++ rtx y1 = XEXP (y, 1); ++ ++ if (GET_CODE (y1) == CONST_INT) ++ return memrefs_conflict_p (xsize, x, ysize, y0, c + INTVAL (y1)); ++ else ++ return 1; ++ } ++ ++ if (GET_CODE (x) == GET_CODE (y)) ++ switch (GET_CODE (x)) ++ { ++ case MULT: ++ { ++ /* Handle cases where we expect the second operands to be the ++ same, and check only whether the first operand would conflict ++ or not. */ ++ rtx x0, y0; ++ rtx x1 = canon_rtx (XEXP (x, 1)); ++ rtx y1 = canon_rtx (XEXP (y, 1)); ++ if (! rtx_equal_for_memref_p (x1, y1)) ++ return 1; ++ x0 = canon_rtx (XEXP (x, 0)); ++ y0 = canon_rtx (XEXP (y, 0)); ++ if (rtx_equal_for_memref_p (x0, y0)) ++ return (xsize == 0 || ysize == 0 ++ || (c >= 0 && xsize > c) || (c < 0 && ysize+c > 0)); ++ ++ /* Can't properly adjust our sizes. */ ++ if (GET_CODE (x1) != CONST_INT) ++ return 1; ++ xsize /= INTVAL (x1); ++ ysize /= INTVAL (x1); ++ c /= INTVAL (x1); ++ return memrefs_conflict_p (xsize, x0, ysize, y0, c); ++ } ++ } ++ ++ /* Treat an access through an AND (e.g. a subword access on an Alpha) ++ as an access with indeterminate size. */ ++ if (GET_CODE (x) == AND && GET_CODE (XEXP (x, 1)) == CONST_INT) ++ return memrefs_conflict_p (0, XEXP (x, 0), ysize, y, c); ++ if (GET_CODE (y) == AND && GET_CODE (XEXP (y, 1)) == CONST_INT) ++ return memrefs_conflict_p (xsize, x, 0, XEXP (y, 0), c); ++ ++ if (CONSTANT_P (x)) ++ { ++ if (GET_CODE (x) == CONST_INT && GET_CODE (y) == CONST_INT) ++ { ++ c += (INTVAL (y) - INTVAL (x)); ++ return (xsize == 0 || ysize == 0 ++ || (c >= 0 && xsize > c) || (c < 0 && ysize+c > 0)); ++ } ++ ++ if (GET_CODE (x) == CONST) ++ { ++ if (GET_CODE (y) == CONST) ++ return memrefs_conflict_p (xsize, canon_rtx (XEXP (x, 0)), ++ ysize, canon_rtx (XEXP (y, 0)), c); ++ else ++ return memrefs_conflict_p (xsize, canon_rtx (XEXP (x, 0)), ++ ysize, y, c); ++ } ++ if (GET_CODE (y) == CONST) ++ return memrefs_conflict_p (xsize, x, ysize, ++ canon_rtx (XEXP (y, 0)), c); ++ ++ if (CONSTANT_P (y)) ++ return (rtx_equal_for_memref_p (x, y) ++ && (xsize == 0 || ysize == 0 ++ || (c >= 0 && xsize > c) || (c < 0 && ysize+c > 0))); ++ ++ return 1; ++ } ++ return 1; ++ } ++ ++ /* Functions to compute memory dependencies. ++ ++ Since we process the insns in execution order, we can build tables ++ to keep track of what registers are fixed (and not aliased), what registers ++ are varying in known ways, and what registers are varying in unknown ++ ways. ++ ++ If both memory references are volatile, then there must always be a ++ dependence between the two references, since their order can not be ++ changed. A volatile and non-volatile reference can be interchanged ++ though. ++ ++ A MEM_IN_STRUCT reference at a non-QImode varying address can never ++ conflict with a non-MEM_IN_STRUCT reference at a fixed address. We must ++ allow QImode aliasing because the ANSI C standard allows character ++ pointers to alias anything. We are assuming that characters are ++ always QImode here. */ ++ ++ /* Read dependence: X is read after read in MEM takes place. There can ++ only be a dependence here if both reads are volatile. */ ++ ++ int ++ read_dependence (mem, x) ++ rtx mem; ++ rtx x; ++ { ++ return MEM_VOLATILE_P (x) && MEM_VOLATILE_P (mem); ++ } ++ ++ /* True dependence: X is read after store in MEM takes place. */ ++ ++ int ++ true_dependence (mem, mem_mode, x, varies) ++ rtx mem; ++ enum machine_mode mem_mode; ++ rtx x; ++ int (*varies)(); ++ { ++ rtx x_addr, mem_addr; ++ ++ if (MEM_VOLATILE_P (x) && MEM_VOLATILE_P (mem)) ++ return 1; ++ ++ x_addr = XEXP (x, 0); ++ mem_addr = XEXP (mem, 0); ++ ++ if (flag_alias_check && ! base_alias_check (x_addr, mem_addr)) ++ return 0; ++ ++ /* If X is an unchanging read, then it can't possibly conflict with any ++ non-unchanging store. It may conflict with an unchanging write though, ++ because there may be a single store to this address to initialize it. ++ Just fall through to the code below to resolve the case where we have ++ both an unchanging read and an unchanging write. This won't handle all ++ cases optimally, but the possible performance loss should be ++ negligible. */ ++ if (RTX_UNCHANGING_P (x) && ! RTX_UNCHANGING_P (mem)) ++ return 0; ++ ++ x_addr = canon_rtx (x_addr); ++ mem_addr = canon_rtx (mem_addr); ++ if (mem_mode == VOIDmode) ++ mem_mode = GET_MODE (mem); ++ ++ if (! memrefs_conflict_p (mem_mode, mem_addr, SIZE_FOR_MODE (x), x_addr, 0)) ++ return 0; ++ ++ /* If both references are struct references, or both are not, nothing ++ is known about aliasing. ++ ++ If either reference is QImode or BLKmode, ANSI C permits aliasing. ++ ++ If both addresses are constant, or both are not, nothing is known ++ about aliasing. */ ++ if (MEM_IN_STRUCT_P (x) == MEM_IN_STRUCT_P (mem) ++ || mem_mode == QImode || mem_mode == BLKmode ++ || GET_MODE (x) == QImode || GET_MODE (mem) == BLKmode ++ || varies (x_addr) == varies (mem_addr)) ++ return 1; ++ ++ /* One memory reference is to a constant address, one is not. ++ One is to a structure, the other is not. ++ ++ If either memory reference is a variable structure the other is a ++ fixed scalar and there is no aliasing. */ ++ if ((MEM_IN_STRUCT_P (mem) && varies (mem_addr)) ++ || (MEM_IN_STRUCT_P (x) && varies (x))) ++ return 0; ++ ++ return 1; ++ } ++ ++ /* Anti dependence: X is written after read in MEM takes place. */ ++ ++ int ++ anti_dependence (mem, x) ++ rtx mem; ++ rtx x; ++ { ++ if (MEM_VOLATILE_P (x) && MEM_VOLATILE_P (mem)) ++ return 1; ++ ++ if (flag_alias_check && ! base_alias_check (XEXP (x, 0), XEXP (mem, 0))) ++ return 0; ++ ++ /* If MEM is an unchanging read, then it can't possibly conflict with ++ the store to X, because there is at most one store to MEM, and it must ++ have occurred somewhere before MEM. */ ++ x = canon_rtx (x); ++ mem = canon_rtx (mem); ++ if (RTX_UNCHANGING_P (mem)) ++ return 0; ++ ++ return (memrefs_conflict_p (SIZE_FOR_MODE (mem), XEXP (mem, 0), ++ SIZE_FOR_MODE (x), XEXP (x, 0), 0) ++ && ! (MEM_IN_STRUCT_P (mem) && rtx_addr_varies_p (mem) ++ && GET_MODE (mem) != QImode ++ && ! MEM_IN_STRUCT_P (x) && ! rtx_addr_varies_p (x)) ++ && ! (MEM_IN_STRUCT_P (x) && rtx_addr_varies_p (x) ++ && GET_MODE (x) != QImode ++ && ! MEM_IN_STRUCT_P (mem) && ! rtx_addr_varies_p (mem))); ++ } ++ ++ /* Output dependence: X is written after store in MEM takes place. */ ++ ++ int ++ output_dependence (mem, x) ++ register rtx mem; ++ register rtx x; ++ { ++ if (MEM_VOLATILE_P (x) && MEM_VOLATILE_P (mem)) ++ return 1; ++ ++ if (flag_alias_check && !base_alias_check (XEXP (x, 0), XEXP (mem, 0))) ++ return 0; ++ ++ x = canon_rtx (x); ++ mem = canon_rtx (mem); ++ return (memrefs_conflict_p (SIZE_FOR_MODE (mem), XEXP (mem, 0), ++ SIZE_FOR_MODE (x), XEXP (x, 0), 0) ++ && ! (MEM_IN_STRUCT_P (mem) && rtx_addr_varies_p (mem) ++ && GET_MODE (mem) != QImode ++ && ! MEM_IN_STRUCT_P (x) && ! rtx_addr_varies_p (x)) ++ && ! (MEM_IN_STRUCT_P (x) && rtx_addr_varies_p (x) ++ && GET_MODE (x) != QImode ++ && ! MEM_IN_STRUCT_P (mem) && ! rtx_addr_varies_p (mem))); ++ } ++ ++ void ++ init_alias_analysis () ++ { ++ int maxreg = max_reg_num (); ++ int changed; ++ register int i; ++ register rtx insn; ++ rtx note; ++ rtx set; ++ ++ reg_known_value_size = maxreg; ++ ++ reg_known_value ++ = (rtx *) oballoc ((maxreg - FIRST_PSEUDO_REGISTER) * sizeof (rtx)) ++ - FIRST_PSEUDO_REGISTER; ++ reg_known_equiv_p = ++ oballoc (maxreg - FIRST_PSEUDO_REGISTER) - FIRST_PSEUDO_REGISTER; ++ bzero ((char *) (reg_known_value + FIRST_PSEUDO_REGISTER), ++ (maxreg-FIRST_PSEUDO_REGISTER) * sizeof (rtx)); ++ bzero (reg_known_equiv_p + FIRST_PSEUDO_REGISTER, ++ (maxreg - FIRST_PSEUDO_REGISTER) * sizeof (char)); ++ ++ if (flag_alias_check) ++ { ++ /* Overallocate reg_base_value to allow some growth during loop ++ optimization. Loop unrolling can create a large number of ++ registers. */ ++ reg_base_value_size = maxreg * 2; ++ reg_base_value = (rtx *)oballoc (reg_base_value_size * sizeof (rtx)); ++ reg_seen = (char *)alloca (reg_base_value_size); ++ bzero (reg_base_value, reg_base_value_size * sizeof (rtx)); ++ bzero (reg_seen, reg_base_value_size); ++ ++ /* Mark all hard registers which may contain an address. ++ The stack, frame and argument pointers may contain an address. ++ An argument register which can hold a Pmode value may contain ++ an address even if it is not in BASE_REGS. ++ ++ The address expression is VOIDmode for an argument and ++ Pmode for other registers. */ ++ #ifndef OUTGOING_REGNO ++ #define OUTGOING_REGNO(N) N ++ #endif ++ for (i = 0; i < FIRST_PSEUDO_REGISTER; i++) ++ /* Check whether this register can hold an incoming pointer ++ argument. FUNCTION_ARG_REGNO_P tests outgoing register ++ numbers, so translate if necessary due to register windows. */ ++ if (FUNCTION_ARG_REGNO_P (OUTGOING_REGNO (i)) && HARD_REGNO_MODE_OK (i, Pmode)) ++ reg_base_value[i] = gen_rtx (ADDRESS, VOIDmode, ++ gen_rtx (REG, Pmode, i)); ++ ++ reg_base_value[STACK_POINTER_REGNUM] ++ = gen_rtx (ADDRESS, Pmode, stack_pointer_rtx); ++ reg_base_value[ARG_POINTER_REGNUM] ++ = gen_rtx (ADDRESS, Pmode, arg_pointer_rtx); ++ reg_base_value[FRAME_POINTER_REGNUM] ++ = gen_rtx (ADDRESS, Pmode, frame_pointer_rtx); ++ reg_base_value[HARD_FRAME_POINTER_REGNUM] ++ = gen_rtx (ADDRESS, Pmode, hard_frame_pointer_rtx); ++ } ++ ++ copying_arguments = 1; ++ /* Fill in the entries with known constant values. */ ++ for (insn = get_insns (); insn; insn = NEXT_INSN (insn)) ++ { ++ if (flag_alias_check && GET_RTX_CLASS (GET_CODE (insn)) == 'i') ++ { ++ /* If this insn has a noalias note, process it, Otherwise, ++ scan for sets. A simple set will have no side effects ++ which could change the base value of any other register. */ ++ rtx noalias_note; ++ if (GET_CODE (PATTERN (insn)) == SET ++ && (noalias_note = find_reg_note (insn, REG_NOALIAS, NULL_RTX))) ++ record_set (SET_DEST (PATTERN (insn)), 0); ++ else ++ note_stores (PATTERN (insn), record_set); ++ } ++ else if (GET_CODE (insn) == NOTE ++ && NOTE_LINE_NUMBER (insn) == NOTE_INSN_FUNCTION_BEG) ++ copying_arguments = 0; ++ ++ if ((set = single_set (insn)) != 0 ++ && GET_CODE (SET_DEST (set)) == REG ++ && REGNO (SET_DEST (set)) >= FIRST_PSEUDO_REGISTER ++ && (((note = find_reg_note (insn, REG_EQUAL, 0)) != 0 ++ && reg_n_sets[REGNO (SET_DEST (set))] == 1) ++ || (note = find_reg_note (insn, REG_EQUIV, NULL_RTX)) != 0) ++ && GET_CODE (XEXP (note, 0)) != EXPR_LIST) ++ { ++ int regno = REGNO (SET_DEST (set)); ++ reg_known_value[regno] = XEXP (note, 0); ++ reg_known_equiv_p[regno] = REG_NOTE_KIND (note) == REG_EQUIV; ++ } ++ } ++ ++ /* Fill in the remaining entries. */ ++ for (i = FIRST_PSEUDO_REGISTER; i < maxreg; i++) ++ if (reg_known_value[i] == 0) ++ reg_known_value[i] = regno_reg_rtx[i]; ++ ++ if (! flag_alias_check) ++ return; ++ ++ /* Simplify the reg_base_value array so that no register refers to ++ another register, except to special registers indirectly through ++ ADDRESS expressions. ++ ++ In theory this loop can take as long as O(registers^2), but unless ++ there are very long dependency chains it will run in close to linear ++ time. */ ++ do ++ { ++ changed = 0; ++ for (i = FIRST_PSEUDO_REGISTER; i < reg_base_value_size; i++) ++ { ++ rtx base = reg_base_value[i]; ++ if (base && GET_CODE (base) == REG) ++ { ++ int base_regno = REGNO (base); ++ if (base_regno == i) /* register set from itself */ ++ reg_base_value[i] = 0; ++ else ++ reg_base_value[i] = reg_base_value[base_regno]; ++ changed = 1; ++ } ++ } ++ } ++ while (changed); ++ ++ reg_seen = 0; ++ } ++ ++ void ++ end_alias_analysis () ++ { ++ reg_known_value = 0; ++ reg_base_value = 0; ++ reg_base_value_size = 0; ++ } +diff -rcp2N gcc-2.7.2.2/c-decl.c g77-new/c-decl.c +*** gcc-2.7.2.2/c-decl.c Fri Oct 27 05:44:43 1995 +--- g77-new/c-decl.c Sun Aug 10 18:46:24 1997 +*************** init_decl_processing () +*** 3207,3210 **** +--- 3207,3223 ---- + builtin_function ("__builtin_cosl", ldouble_ftype_ldouble, + BUILT_IN_COS, "cosl"); ++ builtin_function ("__builtin_setjmp", ++ build_function_type (integer_type_node, ++ tree_cons (NULL_TREE, ++ ptr_type_node, endlink)), ++ BUILT_IN_SETJMP, NULL_PTR); ++ builtin_function ("__builtin_longjmp", ++ build_function_type ++ (void_type_node, ++ tree_cons (NULL, ptr_type_node, ++ tree_cons (NULL_TREE, ++ integer_type_node, ++ endlink))), ++ BUILT_IN_LONGJMP, NULL_PTR); + + /* In an ANSI C program, it is okay to supply built-in meanings +*************** grokdeclarator (declarator, declspecs, d +*** 4049,4052 **** +--- 4062,4066 ---- + int volatilep; + int inlinep; ++ int restrictp; + int explicit_int = 0; + int explicit_char = 0; +*************** grokdeclarator (declarator, declspecs, d +*** 4342,4349 **** +--- 4356,4366 ---- + volatilep = !! (specbits & 1 << (int) RID_VOLATILE) + TYPE_VOLATILE (type); + inlinep = !! (specbits & (1 << (int) RID_INLINE)); ++ restrictp = !! (specbits & (1 << (int) RID_RESTRICT)); + if (constp > 1) + pedwarn ("duplicate `const'"); + if (volatilep > 1) + pedwarn ("duplicate `volatile'"); ++ if (restrictp) ++ error ("`restrict' used in non-parameter or non-pointer type declaration"); + if (! flag_gen_aux_info && (TYPE_READONLY (type) || TYPE_VOLATILE (type))) + type = TYPE_MAIN_VARIANT (type); +*************** grokdeclarator (declarator, declspecs, d +*** 4693,4696 **** +--- 4710,4715 ---- + else if (TREE_VALUE (typemodlist) == ridpointers[(int) RID_VOLATILE]) + volatilep++; ++ else if (TREE_VALUE (typemodlist) == ridpointers[(int) RID_RESTRICT]) ++ restrictp++; + else if (!erred) + { +*************** grokdeclarator (declarator, declspecs, d +*** 4703,4706 **** +--- 4722,4727 ---- + if (volatilep > 1) + pedwarn ("duplicate `volatile'"); ++ if (restrictp > 1) ++ pedwarn ("duplicate `restrict'"); + } + +*************** grokdeclarator (declarator, declspecs, d +*** 4844,4847 **** +--- 4865,4875 ---- + } + ++ if (restrictp) ++ { ++ if (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE) ++ error ("`restrict' applied to non-pointer"); ++ DECL_RESTRICT (decl) = 1; ++ } ++ + DECL_ARG_TYPE_AS_WRITTEN (decl) = type_as_written; + } +*************** start_struct (code, name) +*** 5365,5368 **** +--- 5393,5397 ---- + pushtag (name, ref); + C_TYPE_BEING_DEFINED (ref) = 1; ++ TYPE_PACKED (ref) = flag_pack_struct; + return ref; + } +*************** start_enum (name) +*** 5806,5809 **** +--- 5835,5841 ---- + enum_overflow = 0; + ++ if (flag_short_enums) ++ TYPE_PACKED (enumtype) = 1; ++ + return enumtype; + } +*************** finish_enum (enumtype, values, attribute +*** 5862,5867 **** + precision = MAX (lowprec, highprec); + +! if (flag_short_enums || TYPE_PACKED (enumtype) +! || precision > TYPE_PRECISION (integer_type_node)) + /* Use the width of the narrowest normal C type which is wide enough. */ + TYPE_PRECISION (enumtype) = TYPE_PRECISION (type_for_size (precision, 1)); +--- 5894,5898 ---- + precision = MAX (lowprec, highprec); + +! if (TYPE_PACKED (enumtype) || precision > TYPE_PRECISION (integer_type_node)) + /* Use the width of the narrowest normal C type which is wide enough. */ + TYPE_PRECISION (enumtype) = TYPE_PRECISION (type_for_size (precision, 1)); +diff -rcp2N gcc-2.7.2.2/c-gperf.h g77-new/c-gperf.h +*** gcc-2.7.2.2/c-gperf.h Fri Mar 4 14:15:53 1994 +--- g77-new/c-gperf.h Mon Aug 11 02:58:47 1997 +*************** +*** 1,15 **** + /* C code produced by gperf version 2.5 (GNU C++ version) */ +! /* Command-line: gperf -p -j1 -i 1 -g -o -t -G -N is_reserved_word -k1,3,$ c-parse.gperf */ + struct resword { char *name; short token; enum rid rid; }; + +! #define TOTAL_KEYWORDS 79 + #define MIN_WORD_LENGTH 2 + #define MAX_WORD_LENGTH 20 +! #define MIN_HASH_VALUE 10 +! #define MAX_HASH_VALUE 144 +! /* maximum key range = 135, duplicates = 0 */ + + #ifdef __GNUC__ +! __inline + #endif + static unsigned int +--- 1,16 ---- + /* C code produced by gperf version 2.5 (GNU C++ version) */ +! /* Command-line: gperf -p -j1 -i 1 -g -o -t -G -N is_reserved_word -k1,3,$ ../g77-new/c-parse.gperf */ +! /* Command-line: gperf -p -j1 -i 1 -g -o -t -N is_reserved_word -k1,3,$ c-parse.gperf */ + struct resword { char *name; short token; enum rid rid; }; + +! #define TOTAL_KEYWORDS 81 + #define MIN_WORD_LENGTH 2 + #define MAX_WORD_LENGTH 20 +! #define MIN_HASH_VALUE 11 +! #define MAX_HASH_VALUE 157 +! /* maximum key range = 147, duplicates = 0 */ + + #ifdef __GNUC__ +! inline + #endif + static unsigned int +*************** hash (str, len) +*** 20,36 **** + static unsigned char asso_values[] = + { +! 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, +! 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, +! 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, +! 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, +! 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, +! 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, +! 145, 145, 145, 145, 25, 145, 145, 145, 145, 145, +! 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, +! 145, 145, 145, 145, 145, 145, 145, 145, 145, 145, +! 145, 145, 145, 145, 145, 1, 145, 46, 8, 15, +! 61, 6, 36, 48, 3, 5, 145, 18, 63, 25, +! 29, 76, 1, 145, 13, 2, 1, 51, 37, 9, +! 9, 1, 3, 145, 145, 145, 145, 145, + }; + register int hval = len; +--- 21,37 ---- + static unsigned char asso_values[] = + { +! 158, 158, 158, 158, 158, 158, 158, 158, 158, 158, +! 158, 158, 158, 158, 158, 158, 158, 158, 158, 158, +! 158, 158, 158, 158, 158, 158, 158, 158, 158, 158, +! 158, 158, 158, 158, 158, 158, 158, 158, 158, 158, +! 158, 158, 158, 158, 158, 158, 158, 158, 158, 158, +! 158, 158, 158, 158, 158, 158, 158, 158, 158, 158, +! 158, 158, 158, 158, 2, 158, 158, 158, 158, 158, +! 158, 158, 158, 158, 158, 158, 158, 158, 158, 158, +! 158, 158, 158, 158, 158, 158, 158, 158, 158, 158, +! 158, 158, 158, 158, 158, 1, 158, 18, 1, 58, +! 56, 6, 44, 64, 13, 45, 158, 4, 26, 68, +! 2, 74, 1, 158, 2, 13, 1, 33, 48, 5, +! 5, 3, 12, 158, 158, 158, 158, 158, + }; + register int hval = len; +*************** hash (str, len) +*** 44,47 **** +--- 45,49 ---- + case 1: + hval += asso_values[str[0]]; ++ break; + } + return hval + asso_values[str[len - 1]]; +*************** hash (str, len) +*** 50,166 **** + static struct resword wordlist[] = + { +! {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, +! {"",}, +! {"int", TYPESPEC, RID_INT}, +! {"",}, {"",}, +! {"__typeof__", TYPEOF, NORID}, +! {"__signed__", TYPESPEC, RID_SIGNED}, +! {"__imag__", IMAGPART, NORID}, +! {"switch", SWITCH, NORID}, +! {"__inline__", SCSPEC, RID_INLINE}, +! {"else", ELSE, NORID}, +! {"__iterator__", SCSPEC, RID_ITERATOR}, +! {"__inline", SCSPEC, RID_INLINE}, +! {"__extension__", EXTENSION, NORID}, +! {"struct", STRUCT, NORID}, +! {"__real__", REALPART, NORID}, +! {"__const", TYPE_QUAL, RID_CONST}, +! {"while", WHILE, NORID}, +! {"__const__", TYPE_QUAL, RID_CONST}, +! {"case", CASE, NORID}, +! {"__complex__", TYPESPEC, RID_COMPLEX}, +! {"__iterator", SCSPEC, RID_ITERATOR}, +! {"bycopy", TYPE_QUAL, RID_BYCOPY}, +! {"",}, {"",}, {"",}, +! {"__complex", TYPESPEC, RID_COMPLEX}, +! {"",}, +! {"in", TYPE_QUAL, RID_IN}, +! {"break", BREAK, NORID}, +! {"@defs", DEFS, NORID}, +! {"",}, {"",}, {"",}, +! {"extern", SCSPEC, RID_EXTERN}, +! {"if", IF, NORID}, +! {"typeof", TYPEOF, NORID}, +! {"typedef", SCSPEC, RID_TYPEDEF}, +! {"__typeof", TYPEOF, NORID}, +! {"sizeof", SIZEOF, NORID}, +! {"",}, +! {"return", RETURN, NORID}, +! {"const", TYPE_QUAL, RID_CONST}, +! {"__volatile__", TYPE_QUAL, RID_VOLATILE}, +! {"@private", PRIVATE, NORID}, +! {"@selector", SELECTOR, NORID}, +! {"__volatile", TYPE_QUAL, RID_VOLATILE}, +! {"__asm__", ASM_KEYWORD, NORID}, +! {"",}, {"",}, +! {"continue", CONTINUE, NORID}, +! {"__alignof__", ALIGNOF, NORID}, +! {"__imag", IMAGPART, NORID}, +! {"__attribute__", ATTRIBUTE, NORID}, +! {"",}, {"",}, +! {"__attribute", ATTRIBUTE, NORID}, +! {"for", FOR, NORID}, +! {"",}, +! {"@encode", ENCODE, NORID}, +! {"id", OBJECTNAME, RID_ID}, +! {"static", SCSPEC, RID_STATIC}, +! {"@interface", INTERFACE, NORID}, +! {"",}, +! {"__signed", TYPESPEC, RID_SIGNED}, +! {"",}, +! {"__label__", LABEL, NORID}, +! {"",}, {"",}, +! {"__asm", ASM_KEYWORD, NORID}, +! {"char", TYPESPEC, RID_CHAR}, +! {"",}, +! {"inline", SCSPEC, RID_INLINE}, +! {"out", TYPE_QUAL, RID_OUT}, +! {"register", SCSPEC, RID_REGISTER}, +! {"__real", REALPART, NORID}, +! {"short", TYPESPEC, RID_SHORT}, +! {"",}, +! {"enum", ENUM, NORID}, +! {"inout", TYPE_QUAL, RID_INOUT}, +! {"",}, +! {"oneway", TYPE_QUAL, RID_ONEWAY}, +! {"union", UNION, NORID}, +! {"",}, +! {"__alignof", ALIGNOF, NORID}, +! {"",}, +! {"@implementation", IMPLEMENTATION, NORID}, +! {"",}, +! {"@class", CLASS, NORID}, +! {"",}, +! {"@public", PUBLIC, NORID}, +! {"asm", ASM_KEYWORD, NORID}, +! {"",}, {"",}, {"",}, {"",}, {"",}, +! {"default", DEFAULT, NORID}, +! {"",}, +! {"void", TYPESPEC, RID_VOID}, +! {"",}, +! {"@protected", PROTECTED, NORID}, +! {"@protocol", PROTOCOL, NORID}, +! {"",}, {"",}, {"",}, +! {"volatile", TYPE_QUAL, RID_VOLATILE}, +! {"",}, {"",}, +! {"signed", TYPESPEC, RID_SIGNED}, +! {"float", TYPESPEC, RID_FLOAT}, +! {"@end", END, NORID}, +! {"",}, {"",}, +! {"unsigned", TYPESPEC, RID_UNSIGNED}, +! {"@compatibility_alias", ALIAS, NORID}, +! {"double", TYPESPEC, RID_DOUBLE}, +! {"",}, {"",}, +! {"auto", SCSPEC, RID_AUTO}, +! {"",}, +! {"goto", GOTO, NORID}, +! {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, +! {"do", DO, NORID}, +! {"",}, {"",}, {"",}, {"",}, +! {"long", TYPESPEC, RID_LONG}, + }; + + #ifdef __GNUC__ +! __inline + #endif + struct resword * +--- 52,167 ---- + static struct resword wordlist[] = + { +! {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, +! {"",}, {"",}, +! {"return", RETURN, NORID}, +! {"__real__", REALPART, NORID}, +! {"__typeof__", TYPEOF, NORID}, +! {"__restrict", TYPE_QUAL, RID_RESTRICT}, +! {"extern", SCSPEC, RID_EXTERN}, +! {"break", BREAK, NORID}, +! {"@encode", ENCODE, NORID}, +! {"@private", PRIVATE, NORID}, +! {"@selector", SELECTOR, NORID}, +! {"@interface", INTERFACE, NORID}, +! {"__extension__", EXTENSION, NORID}, +! {"struct", STRUCT, NORID}, +! {"",}, +! {"restrict", TYPE_QUAL, RID_RESTRICT}, +! {"__signed__", TYPESPEC, RID_SIGNED}, +! {"@defs", DEFS, NORID}, +! {"__asm__", ASM_KEYWORD, NORID}, +! {"",}, +! {"else", ELSE, NORID}, +! {"",}, +! {"__alignof__", ALIGNOF, NORID}, +! {"",}, +! {"__attribute__", ATTRIBUTE, NORID}, +! {"",}, +! {"__real", REALPART, NORID}, +! {"__attribute", ATTRIBUTE, NORID}, +! {"__label__", LABEL, NORID}, +! {"",}, +! {"@protocol", PROTOCOL, NORID}, +! {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, +! {"@class", CLASS, NORID}, +! {"",}, +! {"in", TYPE_QUAL, RID_IN}, +! {"int", TYPESPEC, RID_INT}, +! {"for", FOR, NORID}, +! {"typeof", TYPEOF, NORID}, +! {"typedef", SCSPEC, RID_TYPEDEF}, +! {"__typeof", TYPEOF, NORID}, +! {"__imag__", IMAGPART, NORID}, +! {"",}, +! {"__inline__", SCSPEC, RID_INLINE}, +! {"__iterator", SCSPEC, RID_ITERATOR}, +! {"__iterator__", SCSPEC, RID_ITERATOR}, +! {"__inline", SCSPEC, RID_INLINE}, +! {"while", WHILE, NORID}, +! {"__volatile__", TYPE_QUAL, RID_VOLATILE}, +! {"",}, +! {"@end", END, NORID}, +! {"__volatile", TYPE_QUAL, RID_VOLATILE}, +! {"const", TYPE_QUAL, RID_CONST}, +! {"__const", TYPE_QUAL, RID_CONST}, +! {"bycopy", TYPE_QUAL, RID_BYCOPY}, +! {"__const__", TYPE_QUAL, RID_CONST}, +! {"@protected", PROTECTED, NORID}, +! {"__complex__", TYPESPEC, RID_COMPLEX}, +! {"__alignof", ALIGNOF, NORID}, +! {"__complex", TYPESPEC, RID_COMPLEX}, +! {"continue", CONTINUE, NORID}, +! {"sizeof", SIZEOF, NORID}, +! {"register", SCSPEC, RID_REGISTER}, +! {"switch", SWITCH, NORID}, +! {"__signed", TYPESPEC, RID_SIGNED}, +! {"out", TYPE_QUAL, RID_OUT}, +! {"",}, +! {"case", CASE, NORID}, +! {"char", TYPESPEC, RID_CHAR}, +! {"inline", SCSPEC, RID_INLINE}, +! {"",}, +! {"union", UNION, NORID}, +! {"",}, +! {"@implementation", IMPLEMENTATION, NORID}, +! {"volatile", TYPE_QUAL, RID_VOLATILE}, +! {"oneway", TYPE_QUAL, RID_ONEWAY}, +! {"",}, +! {"if", IF, NORID}, +! {"__asm", ASM_KEYWORD, NORID}, +! {"short", TYPESPEC, RID_SHORT}, +! {"",}, +! {"static", SCSPEC, RID_STATIC}, +! {"long", TYPESPEC, RID_LONG}, +! {"auto", SCSPEC, RID_AUTO}, +! {"",}, {"",}, +! {"@public", PUBLIC, NORID}, +! {"double", TYPESPEC, RID_DOUBLE}, +! {"",}, +! {"id", OBJECTNAME, RID_ID}, +! {"",}, {"",}, {"",}, {"",}, +! {"default", DEFAULT, NORID}, +! {"@compatibility_alias", ALIAS, NORID}, +! {"unsigned", TYPESPEC, RID_UNSIGNED}, +! {"enum", ENUM, NORID}, +! {"",}, {"",}, {"",}, {"",}, +! {"__imag", IMAGPART, NORID}, +! {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, +! {"float", TYPESPEC, RID_FLOAT}, +! {"inout", TYPE_QUAL, RID_INOUT}, +! {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, +! {"do", DO, NORID}, +! {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, +! {"signed", TYPESPEC, RID_SIGNED}, +! {"",}, {"",}, {"",}, +! {"goto", GOTO, NORID}, +! {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, {"",}, +! {"void", TYPESPEC, RID_VOID}, +! {"",}, {"",}, {"",}, +! {"asm", ASM_KEYWORD, NORID}, + }; + + #ifdef __GNUC__ +! inline + #endif + struct resword * +diff -rcp2N gcc-2.7.2.2/c-lex.c g77-new/c-lex.c +*** gcc-2.7.2.2/c-lex.c Thu Jun 15 07:11:39 1995 +--- g77-new/c-lex.c Sun Aug 10 18:46:49 1997 +*************** init_lex () +*** 173,176 **** +--- 173,177 ---- + ridpointers[(int) RID_CONST] = get_identifier ("const"); + ridpointers[(int) RID_VOLATILE] = get_identifier ("volatile"); ++ ridpointers[(int) RID_RESTRICT] = get_identifier ("restrict"); + ridpointers[(int) RID_AUTO] = get_identifier ("auto"); + ridpointers[(int) RID_STATIC] = get_identifier ("static"); +*************** init_lex () +*** 206,209 **** +--- 207,211 ---- + UNSET_RESERVED_WORD ("iterator"); + UNSET_RESERVED_WORD ("complex"); ++ UNSET_RESERVED_WORD ("restrict"); + } + if (flag_no_asm) +*************** init_lex () +*** 214,217 **** +--- 216,220 ---- + UNSET_RESERVED_WORD ("iterator"); + UNSET_RESERVED_WORD ("complex"); ++ UNSET_RESERVED_WORD ("restrict"); + } + } +*************** yylex () +*** 1433,1437 **** + /* Create a node with determined type and value. */ + if (imag) +! yylval.ttype = build_complex (convert (type, integer_zero_node), + build_real (type, value)); + else +--- 1436,1441 ---- + /* Create a node with determined type and value. */ + if (imag) +! yylval.ttype = build_complex (NULL_TREE, +! convert (type, integer_zero_node), + build_real (type, value)); + else +*************** yylex () +*** 1624,1629 **** + <= TYPE_PRECISION (integer_type_node)) + yylval.ttype +! = build_complex (integer_zero_node, +! convert (integer_type_node, yylval.ttype)); + else + error ("complex integer constant is too wide for `complex int'"); +--- 1628,1634 ---- + <= TYPE_PRECISION (integer_type_node)) + yylval.ttype +! = build_complex (NULL_TREE, integer_zero_node, +! convert (integer_type_node, +! yylval.ttype)); + else + error ("complex integer constant is too wide for `complex int'"); +diff -rcp2N gcc-2.7.2.2/c-lex.h g77-new/c-lex.h +*** gcc-2.7.2.2/c-lex.h Thu Jun 15 07:12:22 1995 +--- g77-new/c-lex.h Sun Aug 10 18:10:55 1997 +*************** enum rid +*** 43,47 **** + RID_VOLATILE, + RID_INLINE, +! RID_NOALIAS, + RID_ITERATOR, + RID_COMPLEX, +--- 43,47 ---- + RID_VOLATILE, + RID_INLINE, +! RID_RESTRICT, + RID_ITERATOR, + RID_COMPLEX, +diff -rcp2N gcc-2.7.2.2/c-parse.gperf g77-new/c-parse.gperf +*** gcc-2.7.2.2/c-parse.gperf Fri Apr 9 19:00:44 1993 +--- g77-new/c-parse.gperf Sun Aug 10 18:10:55 1997 +*************** __label__, LABEL, NORID +*** 36,39 **** +--- 36,40 ---- + __real, REALPART, NORID + __real__, REALPART, NORID ++ __restrict, TYPE_QUAL, RID_RESTRICT + __signed, TYPESPEC, RID_SIGNED + __signed__, TYPESPEC, RID_SIGNED +*************** oneway, TYPE_QUAL, RID_ONEWAY +*** 69,72 **** +--- 70,74 ---- + out, TYPE_QUAL, RID_OUT + register, SCSPEC, RID_REGISTER ++ restrict, TYPE_QUAL, RID_RESTRICT + return, RETURN, NORID + short, TYPESPEC, RID_SHORT +diff -rcp2N gcc-2.7.2.2/c-typeck.c g77-new/c-typeck.c +*** gcc-2.7.2.2/c-typeck.c Thu Feb 20 19:24:11 1997 +--- g77-new/c-typeck.c Sun Aug 10 18:46:29 1997 +*************** pointer_int_sum (resultcode, ptrop, into +*** 2681,2686 **** + so the multiply won't overflow spuriously. */ + +! if (TYPE_PRECISION (TREE_TYPE (intop)) != POINTER_SIZE) +! intop = convert (type_for_size (POINTER_SIZE, 0), intop); + + /* Replace the integer argument with a suitable product by the object size. +--- 2681,2688 ---- + so the multiply won't overflow spuriously. */ + +! if (TYPE_PRECISION (TREE_TYPE (intop)) != TYPE_PRECISION (sizetype) +! || TREE_UNSIGNED (TREE_TYPE (intop)) != TREE_UNSIGNED (sizetype)) +! intop = convert (type_for_size (TYPE_PRECISION (sizetype), +! TREE_UNSIGNED (sizetype)), intop); + + /* Replace the integer argument with a suitable product by the object size. +diff -rcp2N gcc-2.7.2.2/calls.c g77-new/calls.c +*** gcc-2.7.2.2/calls.c Thu Oct 26 21:53:43 1995 +--- g77-new/calls.c Sun Aug 10 18:46:16 1997 +*************** expand_call (exp, target, ignore) +*** 564,567 **** +--- 564,569 ---- + /* Nonzero if it is plausible that this is a call to alloca. */ + int may_be_alloca; ++ /* Nonzero if this is a call to malloc or a related function. */ ++ int is_malloc; + /* Nonzero if this is a call to setjmp or a related function. */ + int returns_twice; +*************** expand_call (exp, target, ignore) +*** 741,745 **** + if (stack_arg_under_construction || i >= 0) + { +! rtx insn = NEXT_INSN (before_call), seq; + + /* Look for a call in the inline function code. +--- 743,749 ---- + if (stack_arg_under_construction || i >= 0) + { +! rtx first_insn +! = before_call ? NEXT_INSN (before_call) : get_insns (); +! rtx insn, seq; + + /* Look for a call in the inline function code. +*************** expand_call (exp, target, ignore) +*** 749,753 **** + + if (OUTGOING_ARGS_SIZE (DECL_SAVED_INSNS (fndecl)) == 0) +! for (; insn; insn = NEXT_INSN (insn)) + if (GET_CODE (insn) == CALL_INSN) + break; +--- 753,757 ---- + + if (OUTGOING_ARGS_SIZE (DECL_SAVED_INSNS (fndecl)) == 0) +! for (insn = first_insn; insn; insn = NEXT_INSN (insn)) + if (GET_CODE (insn) == CALL_INSN) + break; +*************** expand_call (exp, target, ignore) +*** 781,785 **** + seq = get_insns (); + end_sequence (); +! emit_insns_before (seq, NEXT_INSN (before_call)); + emit_stack_restore (SAVE_BLOCK, old_stack_level, NULL_RTX); + } +--- 785,789 ---- + seq = get_insns (); + end_sequence (); +! emit_insns_before (seq, first_insn); + emit_stack_restore (SAVE_BLOCK, old_stack_level, NULL_RTX); + } +*************** expand_call (exp, target, ignore) +*** 852,855 **** +--- 856,860 ---- + returns_twice = 0; + is_longjmp = 0; ++ is_malloc = 0; + + if (name != 0 && IDENTIFIER_LENGTH (DECL_NAME (fndecl)) <= 15) +*************** expand_call (exp, target, ignore) +*** 891,894 **** +--- 896,903 ---- + && ! strcmp (tname, "longjmp")) + is_longjmp = 1; ++ /* Only recognize malloc when alias analysis is enabled. */ ++ else if (tname[0] == 'm' && flag_alias_check ++ && ! strcmp(tname, "malloc")) ++ is_malloc = 1; + } + +*************** expand_call (exp, target, ignore) +*** 1087,1090 **** +--- 1096,1100 ---- + + store_expr (args[i].tree_value, copy, 0); ++ is_const = 0; + + args[i].tree_value = build1 (ADDR_EXPR, +*************** expand_call (exp, target, ignore) +*** 1363,1367 **** + /* Now we are about to start emitting insns that can be deleted + if a libcall is deleted. */ +! if (is_const) + start_sequence (); + +--- 1373,1377 ---- + /* Now we are about to start emitting insns that can be deleted + if a libcall is deleted. */ +! if (is_const || is_malloc) + start_sequence (); + +*************** expand_call (exp, target, ignore) +*** 1951,1954 **** +--- 1961,1978 ---- + end_sequence (); + emit_insns (insns); ++ } ++ else if (is_malloc) ++ { ++ rtx temp = gen_reg_rtx (GET_MODE (valreg)); ++ rtx last, insns; ++ ++ emit_move_insn (temp, valreg); ++ last = get_last_insn (); ++ REG_NOTES (last) = ++ gen_rtx (EXPR_LIST, REG_NOALIAS, temp, REG_NOTES (last)); ++ insns = get_insns (); ++ end_sequence (); ++ emit_insns (insns); ++ valreg = temp; + } + +diff -rcp2N gcc-2.7.2.2/cccp.c g77-new/cccp.c +*** gcc-2.7.2.2/cccp.c Thu Oct 26 18:07:26 1995 +--- g77-new/cccp.c Sun Aug 10 18:45:53 1997 +*************** initialize_builtins (inp, outp) +*** 9626,9629 **** +--- 9626,9630 ---- + so that it is present only when truly compiling with GNU C. */ + /* install ((U_CHAR *) "__GNUC__", -1, T_CONST, "2", -1); */ ++ install ((U_CHAR *) "__HAVE_BUILTIN_SETJMP__", -1, T_CONST, "1", -1); + + if (debug_output) +diff -rcp2N gcc-2.7.2.2/combine.c g77-new/combine.c +*** gcc-2.7.2.2/combine.c Sun Nov 26 14:32:07 1995 +--- g77-new/combine.c Mon Jul 28 21:44:17 1997 +*************** num_sign_bit_copies (x, mode) +*** 7326,7329 **** +--- 7326,7335 ---- + + case NEG: ++ while (GET_MODE (XEXP (x, 0)) == GET_MODE (x) ++ && GET_CODE (XEXP (x, 0)) == NEG ++ && GET_MODE (XEXP (XEXP (x, 0), 0)) == GET_MODE (x) ++ && GET_CODE (XEXP (XEXP (x, 0), 0)) == NEG) ++ x = XEXP (XEXP (x, 0), 0); /* Speed up 961126-1.c */ ++ + /* In general, this subtracts one sign bit copy. But if the value + is known to be positive, the number of sign bit copies is the +*************** distribute_notes (notes, from_insn, i3, +*** 10648,10651 **** +--- 10654,10658 ---- + case REG_EQUIV: + case REG_NONNEG: ++ case REG_NOALIAS: + /* These notes say something about results of an insn. We can + only support them if they used to be on I3 in which case they +diff -rcp2N gcc-2.7.2.2/config/alpha/alpha.c g77-new/config/alpha/alpha.c +*** gcc-2.7.2.2/config/alpha/alpha.c Thu Feb 20 19:24:11 1997 +--- g77-new/config/alpha/alpha.c Thu Jul 10 20:08:47 1997 +*************** direct_return () +*** 1239,1243 **** + cross-compiler. Otherwise, use the versions in /usr/include/stamp.h. */ + +! #if !defined(CROSS_COMPILE) && !defined(_WIN32) + #include + #endif +--- 1239,1243 ---- + cross-compiler. Otherwise, use the versions in /usr/include/stamp.h. */ + +! #if !defined(CROSS_COMPILE) && !defined(_WIN32) && !defined(__linux__) + #include + #endif +*************** output_prolog (file, size) +*** 1370,1373 **** +--- 1370,1378 ---- + + alpha_function_needs_gp = 0; ++ #ifdef __linux__ ++ if(profile_flag) { ++ alpha_function_needs_gp = 1; ++ } ++ #endif + for (insn = get_insns (); insn; insn = NEXT_INSN (insn)) + if ((GET_CODE (insn) == CALL_INSN) +diff -rcp2N gcc-2.7.2.2/config/alpha/alpha.h g77-new/config/alpha/alpha.h +*** gcc-2.7.2.2/config/alpha/alpha.h Thu Feb 20 19:24:12 1997 +--- g77-new/config/alpha/alpha.h Sun Aug 10 19:21:39 1997 +*************** extern int target_flags; +*** 112,116 **** +--- 112,118 ---- + {"", TARGET_DEFAULT | TARGET_CPU_DEFAULT} } + ++ #ifndef TARGET_DEFAULT + #define TARGET_DEFAULT 3 ++ #endif + + #ifndef TARGET_CPU_DEFAULT +*************** extern int target_flags; +*** 252,255 **** +--- 254,260 ---- + /* No data type wants to be aligned rounder than this. */ + #define BIGGEST_ALIGNMENT 64 ++ ++ /* For atomic access to objects, must have at least 32-bit alignment. */ ++ #define MINIMUM_ATOMIC_ALIGNMENT 32 + + /* Make strings word-aligned so strcpy from constants will be faster. */ +diff -rcp2N gcc-2.7.2.2/config/alpha/alpha.md g77-new/config/alpha/alpha.md +*** gcc-2.7.2.2/config/alpha/alpha.md Fri Oct 27 06:49:59 1995 +--- g77-new/config/alpha/alpha.md Thu Jul 10 20:08:48 1997 +*************** +*** 1746,1752 **** + (if_then_else:DF + (match_operator 3 "signed_comparison_operator" +! [(match_operand:DF 1 "reg_or_fp0_operand" "fG,fG") + (match_operand:DF 2 "fp0_operand" "G,G")]) +! (float_extend:DF (match_operand:SF 4 "reg_or_fp0_operand" "fG,0")) + (match_operand:DF 5 "reg_or_fp0_operand" "0,fG")))] + "TARGET_FP" +--- 1746,1752 ---- + (if_then_else:DF + (match_operator 3 "signed_comparison_operator" +! [(match_operand:DF 4 "reg_or_fp0_operand" "fG,fG") + (match_operand:DF 2 "fp0_operand" "G,G")]) +! (float_extend:DF (match_operand:SF 1 "reg_or_fp0_operand" "fG,0")) + (match_operand:DF 5 "reg_or_fp0_operand" "0,fG")))] + "TARGET_FP" +diff -rcp2N gcc-2.7.2.2/config/alpha/elf.h g77-new/config/alpha/elf.h +*** gcc-2.7.2.2/config/alpha/elf.h Wed Dec 31 19:00:00 1969 +--- g77-new/config/alpha/elf.h Thu Jul 10 20:08:49 1997 +*************** +*** 0 **** +--- 1,522 ---- ++ /* Definitions of target machine for GNU compiler, for DEC Alpha w/ELF. ++ Copyright (C) 1996 Free Software Foundation, Inc. ++ Contributed by Richard Henderson (rth@tamu.edu). ++ ++ This file is part of GNU CC. ++ ++ GNU CC is free software; you can redistribute it and/or modify ++ it under the terms of the GNU General Public License as published by ++ the Free Software Foundation; either version 2, or (at your option) ++ any later version. ++ ++ GNU CC is distributed in the hope that it will be useful, ++ but WITHOUT ANY WARRANTY; without even the implied warranty of ++ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ++ GNU General Public License for more details. ++ ++ You should have received a copy of the GNU General Public License ++ along with GNU CC; see the file COPYING. If not, write to ++ the Free Software Foundation, 59 Temple Place - Suite 330, ++ Boston, MA 02111-1307, USA. */ ++ ++ /* This is used on Alpha platforms that use the ELF format. ++ Currently only Linux uses this. */ ++ ++ #include "alpha/linux.h" ++ ++ #undef TARGET_VERSION ++ #define TARGET_VERSION fprintf (stderr, " (Alpha Linux/ELF)"); ++ ++ #undef OBJECT_FORMAT_COFF ++ #undef EXTENDED_COFF ++ #define OBJECT_FORMAT_ELF ++ ++ #define SDB_DEBUGGING_INFO ++ ++ #undef ASM_FINAL_SPEC ++ ++ #undef CPP_PREDEFINES ++ #define CPP_PREDEFINES "\ ++ -D__alpha -D__alpha__ -D__linux__ -D__linux -D_LONGLONG -Dlinux -Dunix \ ++ -Asystem(linux) -Acpu(alpha) -Amachine(alpha) -D__ELF__" ++ ++ #undef LINK_SPEC ++ #define LINK_SPEC "-m elf64alpha -G 8 %{O*:-O3} %{!O*:-O1} \ ++ %{shared:-shared} \ ++ %{!shared: \ ++ %{!static: \ ++ %{rdynamic:-export-dynamic} \ ++ %{!dynamic-linker:-dynamic-linker /lib/ld.so.1}} \ ++ %{static:-static}}" ++ ++ /* Output at beginning of assembler file. */ ++ ++ #undef ASM_FILE_START ++ #define ASM_FILE_START(FILE) \ ++ { \ ++ alpha_write_verstamp (FILE); \ ++ output_file_directive (FILE, main_input_filename); \ ++ fprintf (FILE, "\t.version\t\"01.01\"\n"); \ ++ fprintf (FILE, "\t.set noat\n"); \ ++ } ++ ++ #define ASM_OUTPUT_SOURCE_LINE(STREAM, LINE) \ ++ alpha_output_lineno (STREAM, LINE) ++ extern void alpha_output_lineno (); ++ ++ extern void output_file_directive (); ++ ++ /* Attach a special .ident directive to the end of the file to identify ++ the version of GCC which compiled this code. The format of the ++ .ident string is patterned after the ones produced by native svr4 ++ C compilers. */ ++ ++ #define IDENT_ASM_OP ".ident" ++ ++ #ifdef IDENTIFY_WITH_IDENT ++ #define ASM_IDENTIFY_GCC(FILE) /* nothing */ ++ #define ASM_IDENTIFY_LANGUAGE(FILE) \ ++ fprintf(FILE, "\t%s \"GCC (%s) %s\"\n", IDENT_ASM_OP, \ ++ lang_identify(), version_string) ++ #else ++ #define ASM_FILE_END(FILE) \ ++ do { \ ++ fprintf ((FILE), "\t%s\t\"GCC: (GNU) %s\"\n", \ ++ IDENT_ASM_OP, version_string); \ ++ } while (0) ++ #endif ++ ++ /* Allow #sccs in preprocessor. */ ++ ++ #define SCCS_DIRECTIVE ++ ++ /* Output #ident as a .ident. */ ++ ++ #define ASM_OUTPUT_IDENT(FILE, NAME) \ ++ fprintf (FILE, "\t%s\t\"%s\"\n", IDENT_ASM_OP, NAME); ++ ++ /* This is how to allocate empty space in some section. The .zero ++ pseudo-op is used for this on most svr4 assemblers. */ ++ ++ #define SKIP_ASM_OP ".zero" ++ ++ #undef ASM_OUTPUT_SKIP ++ #define ASM_OUTPUT_SKIP(FILE,SIZE) \ ++ fprintf (FILE, "\t%s\t%u\n", SKIP_ASM_OP, (SIZE)) ++ ++ /* Output the label which precedes a jumptable. Note that for all svr4 ++ systems where we actually generate jumptables (which is to say every ++ svr4 target except i386, where we use casesi instead) we put the jump- ++ tables into the .rodata section and since other stuff could have been ++ put into the .rodata section prior to any given jumptable, we have to ++ make sure that the location counter for the .rodata section gets pro- ++ perly re-aligned prior to the actual beginning of the jump table. */ ++ ++ #define ALIGN_ASM_OP ".align" ++ ++ #ifndef ASM_OUTPUT_BEFORE_CASE_LABEL ++ #define ASM_OUTPUT_BEFORE_CASE_LABEL(FILE,PREFIX,NUM,TABLE) \ ++ ASM_OUTPUT_ALIGN ((FILE), 2); ++ #endif ++ ++ #undef ASM_OUTPUT_CASE_LABEL ++ #define ASM_OUTPUT_CASE_LABEL(FILE,PREFIX,NUM,JUMPTABLE) \ ++ do { \ ++ ASM_OUTPUT_BEFORE_CASE_LABEL (FILE, PREFIX, NUM, JUMPTABLE) \ ++ ASM_OUTPUT_INTERNAL_LABEL (FILE, PREFIX, NUM); \ ++ } while (0) ++ ++ /* The standard SVR4 assembler seems to require that certain builtin ++ library routines (e.g. .udiv) be explicitly declared as .globl ++ in each assembly file where they are referenced. */ ++ ++ #define ASM_OUTPUT_EXTERNAL_LIBCALL(FILE, FUN) \ ++ ASM_GLOBALIZE_LABEL (FILE, XSTR (FUN, 0)) ++ ++ /* This says how to output assembler code to declare an ++ uninitialized external linkage data object. Under SVR4, ++ the linker seems to want the alignment of data objects ++ to depend on their types. We do exactly that here. */ ++ ++ #define COMMON_ASM_OP ".comm" ++ ++ #undef ASM_OUTPUT_ALIGNED_COMMON ++ #define ASM_OUTPUT_ALIGNED_COMMON(FILE, NAME, SIZE, ALIGN) \ ++ do { \ ++ fprintf ((FILE), "\t%s\t", COMMON_ASM_OP); \ ++ assemble_name ((FILE), (NAME)); \ ++ fprintf ((FILE), ",%u,%u\n", (SIZE), (ALIGN) / BITS_PER_UNIT); \ ++ } while (0) ++ ++ /* This says how to output assembler code to declare an ++ uninitialized internal linkage data object. Under SVR4, ++ the linker seems to want the alignment of data objects ++ to depend on their types. We do exactly that here. */ ++ ++ #define LOCAL_ASM_OP ".local" ++ ++ #undef ASM_OUTPUT_ALIGNED_LOCAL ++ #define ASM_OUTPUT_ALIGNED_LOCAL(FILE, NAME, SIZE, ALIGN) \ ++ do { \ ++ fprintf ((FILE), "\t%s\t", LOCAL_ASM_OP); \ ++ assemble_name ((FILE), (NAME)); \ ++ fprintf ((FILE), "\n"); \ ++ ASM_OUTPUT_ALIGNED_COMMON (FILE, NAME, SIZE, ALIGN); \ ++ } while (0) ++ ++ /* This is the pseudo-op used to generate a 64-bit word of data with a ++ specific value in some section. */ ++ ++ #define INT_ASM_OP ".quad" ++ ++ /* This is the pseudo-op used to generate a contiguous sequence of byte ++ values from a double-quoted string WITHOUT HAVING A TERMINATING NUL ++ AUTOMATICALLY APPENDED. This is the same for most svr4 assemblers. */ ++ ++ #undef ASCII_DATA_ASM_OP ++ #define ASCII_DATA_ASM_OP ".ascii" ++ ++ /* Support const sections and the ctors and dtors sections for g++. ++ Note that there appears to be two different ways to support const ++ sections at the moment. You can either #define the symbol ++ READONLY_DATA_SECTION (giving it some code which switches to the ++ readonly data section) or else you can #define the symbols ++ EXTRA_SECTIONS, EXTRA_SECTION_FUNCTIONS, SELECT_SECTION, and ++ SELECT_RTX_SECTION. We do both here just to be on the safe side. */ ++ ++ #define USE_CONST_SECTION 1 ++ ++ #define CONST_SECTION_ASM_OP ".section\t.rodata" ++ ++ /* Define the pseudo-ops used to switch to the .ctors and .dtors sections. ++ ++ Note that we want to give these sections the SHF_WRITE attribute ++ because these sections will actually contain data (i.e. tables of ++ addresses of functions in the current root executable or shared library ++ file) and, in the case of a shared library, the relocatable addresses ++ will have to be properly resolved/relocated (and then written into) by ++ the dynamic linker when it actually attaches the given shared library ++ to the executing process. (Note that on SVR4, you may wish to use the ++ `-z text' option to the ELF linker, when building a shared library, as ++ an additional check that you are doing everything right. But if you do ++ use the `-z text' option when building a shared library, you will get ++ errors unless the .ctors and .dtors sections are marked as writable ++ via the SHF_WRITE attribute.) */ ++ ++ #define CTORS_SECTION_ASM_OP ".section\t.ctors,\"aw\"" ++ #define DTORS_SECTION_ASM_OP ".section\t.dtors,\"aw\"" ++ ++ /* On svr4, we *do* have support for the .init and .fini sections, and we ++ can put stuff in there to be executed before and after `main'. We let ++ crtstuff.c and other files know this by defining the following symbols. ++ The definitions say how to change sections to the .init and .fini ++ sections. This is the same for all known svr4 assemblers. */ ++ ++ #define INIT_SECTION_ASM_OP ".section\t.init" ++ #define FINI_SECTION_ASM_OP ".section\t.fini" ++ ++ /* Support non-common, uninitialized data in the .bss section. */ ++ ++ #define BSS_SECTION_ASM_OP ".section\t.bss" ++ ++ /* A default list of other sections which we might be "in" at any given ++ time. For targets that use additional sections (e.g. .tdesc) you ++ should override this definition in the target-specific file which ++ includes this file. */ ++ ++ #undef EXTRA_SECTIONS ++ #define EXTRA_SECTIONS in_const, in_ctors, in_dtors, in_bss ++ ++ /* A default list of extra section function definitions. For targets ++ that use additional sections (e.g. .tdesc) you should override this ++ definition in the target-specific file which includes this file. */ ++ ++ #undef EXTRA_SECTION_FUNCTIONS ++ #define EXTRA_SECTION_FUNCTIONS \ ++ CONST_SECTION_FUNCTION \ ++ CTORS_SECTION_FUNCTION \ ++ DTORS_SECTION_FUNCTION \ ++ BSS_SECTION_FUNCTION ++ ++ #undef READONLY_DATA_SECTION ++ #define READONLY_DATA_SECTION() const_section () ++ ++ extern void text_section (); ++ ++ #define CONST_SECTION_FUNCTION \ ++ void \ ++ const_section () \ ++ { \ ++ if (!USE_CONST_SECTION) \ ++ text_section(); \ ++ else if (in_section != in_const) \ ++ { \ ++ fprintf (asm_out_file, "%s\n", CONST_SECTION_ASM_OP); \ ++ in_section = in_const; \ ++ } \ ++ } ++ ++ #define CTORS_SECTION_FUNCTION \ ++ void \ ++ ctors_section () \ ++ { \ ++ if (in_section != in_ctors) \ ++ { \ ++ fprintf (asm_out_file, "%s\n", CTORS_SECTION_ASM_OP); \ ++ in_section = in_ctors; \ ++ } \ ++ } ++ ++ #define DTORS_SECTION_FUNCTION \ ++ void \ ++ dtors_section () \ ++ { \ ++ if (in_section != in_dtors) \ ++ { \ ++ fprintf (asm_out_file, "%s\n", DTORS_SECTION_ASM_OP); \ ++ in_section = in_dtors; \ ++ } \ ++ } ++ ++ #define BSS_SECTION_FUNCTION \ ++ void \ ++ bss_section () \ ++ { \ ++ if (in_section != in_bss) \ ++ { \ ++ fprintf (asm_out_file, "%s\n", BSS_SECTION_ASM_OP); \ ++ in_section = in_bss; \ ++ } \ ++ } ++ ++ ++ /* Switch into a generic section. ++ This is currently only used to support section attributes. ++ ++ We make the section read-only and executable for a function decl, ++ read-only for a const data decl, and writable for a non-const data decl. */ ++ #define ASM_OUTPUT_SECTION_NAME(FILE, DECL, NAME) \ ++ fprintf (FILE, ".section\t%s,\"%s\",@progbits\n", NAME, \ ++ (DECL) && TREE_CODE (DECL) == FUNCTION_DECL ? "ax" : \ ++ (DECL) && TREE_READONLY (DECL) ? "a" : "aw") ++ ++ ++ /* A C statement (sans semicolon) to output an element in the table of ++ global constructors. */ ++ #define ASM_OUTPUT_CONSTRUCTOR(FILE,NAME) \ ++ do { \ ++ ctors_section (); \ ++ fprintf (FILE, "\t%s\t ", INT_ASM_OP); \ ++ assemble_name (FILE, NAME); \ ++ fprintf (FILE, "\n"); \ ++ } while (0) ++ ++ /* A C statement (sans semicolon) to output an element in the table of ++ global destructors. */ ++ #define ASM_OUTPUT_DESTRUCTOR(FILE,NAME) \ ++ do { \ ++ dtors_section (); \ ++ fprintf (FILE, "\t%s\t ", INT_ASM_OP); \ ++ assemble_name (FILE, NAME); \ ++ fprintf (FILE, "\n"); \ ++ } while (0) ++ ++ /* A C statement or statements to switch to the appropriate ++ section for output of DECL. DECL is either a `VAR_DECL' node ++ or a constant of some sort. RELOC indicates whether forming ++ the initial value of DECL requires link-time relocations. */ ++ ++ #define SELECT_SECTION(DECL,RELOC) \ ++ { \ ++ if (TREE_CODE (DECL) == STRING_CST) \ ++ { \ ++ if (! flag_writable_strings) \ ++ const_section (); \ ++ else \ ++ data_section (); \ ++ } \ ++ else if (TREE_CODE (DECL) == VAR_DECL) \ ++ { \ ++ if ((flag_pic && RELOC) \ ++ || !TREE_READONLY (DECL) || TREE_SIDE_EFFECTS (DECL) \ ++ || !DECL_INITIAL (DECL) \ ++ || (DECL_INITIAL (DECL) != error_mark_node \ ++ && !TREE_CONSTANT (DECL_INITIAL (DECL)))) \ ++ { \ ++ if (DECL_COMMON (DECL) \ ++ && !DECL_INITIAL (DECL)) \ ++ /* || DECL_INITIAL (DECL) == error_mark_node)) */ \ ++ bss_section(); \ ++ else \ ++ data_section (); \ ++ } \ ++ else \ ++ const_section (); \ ++ } \ ++ else \ ++ const_section (); \ ++ } ++ ++ /* A C statement or statements to switch to the appropriate ++ section for output of RTX in mode MODE. RTX is some kind ++ of constant in RTL. The argument MODE is redundant except ++ in the case of a `const_int' rtx. Currently, these always ++ go into the const section. */ ++ ++ #undef SELECT_RTX_SECTION ++ #define SELECT_RTX_SECTION(MODE,RTX) const_section() ++ ++ /* Define the strings used for the special svr4 .type and .size directives. ++ These strings generally do not vary from one system running svr4 to ++ another, but if a given system (e.g. m88k running svr) needs to use ++ different pseudo-op names for these, they may be overridden in the ++ file which includes this one. */ ++ ++ #define TYPE_ASM_OP ".type" ++ #define SIZE_ASM_OP ".size" ++ ++ /* This is how we tell the assembler that a symbol is weak. */ ++ ++ #define ASM_WEAKEN_LABEL(FILE,NAME) \ ++ do { fputs ("\t.weak\t", FILE); assemble_name (FILE, NAME); \ ++ fputc ('\n', FILE); } while (0) ++ ++ /* This is how we tell the assembler that two symbols have the same value. */ ++ ++ #define ASM_OUTPUT_DEF(FILE,NAME1,NAME2) \ ++ do { assemble_name(FILE, NAME1); \ ++ fputs(" = ", FILE); \ ++ assemble_name(FILE, NAME2); \ ++ fputc('\n', FILE); } while (0) ++ ++ /* The following macro defines the format used to output the second ++ operand of the .type assembler directive. Different svr4 assemblers ++ expect various different forms for this operand. The one given here ++ is just a default. You may need to override it in your machine- ++ specific tm.h file (depending upon the particulars of your assembler). */ ++ ++ #define TYPE_OPERAND_FMT "@%s" ++ ++ /* Write the extra assembler code needed to declare a function's result. ++ Most svr4 assemblers don't require any special declaration of the ++ result value, but there are exceptions. */ ++ ++ #ifndef ASM_DECLARE_RESULT ++ #define ASM_DECLARE_RESULT(FILE, RESULT) ++ #endif ++ ++ /* These macros generate the special .type and .size directives which ++ are used to set the corresponding fields of the linker symbol table ++ entries in an ELF object file under SVR4. These macros also output ++ the starting labels for the relevant functions/objects. */ ++ ++ /* Write the extra assembler code needed to declare an object properly. */ ++ ++ #define ASM_DECLARE_OBJECT_NAME(FILE, NAME, DECL) \ ++ do { \ ++ fprintf (FILE, "\t%s\t ", TYPE_ASM_OP); \ ++ assemble_name (FILE, NAME); \ ++ putc (',', FILE); \ ++ fprintf (FILE, TYPE_OPERAND_FMT, "object"); \ ++ putc ('\n', FILE); \ ++ size_directive_output = 0; \ ++ if (!flag_inhibit_size_directive && DECL_SIZE (DECL)) \ ++ { \ ++ size_directive_output = 1; \ ++ fprintf (FILE, "\t%s\t ", SIZE_ASM_OP); \ ++ assemble_name (FILE, NAME); \ ++ fprintf (FILE, ",%d\n", int_size_in_bytes (TREE_TYPE (DECL))); \ ++ } \ ++ ASM_OUTPUT_LABEL(FILE, NAME); \ ++ } while (0) ++ ++ /* Output the size directive for a decl in rest_of_decl_compilation ++ in the case where we did not do so before the initializer. ++ Once we find the error_mark_node, we know that the value of ++ size_directive_output was set ++ by ASM_DECLARE_OBJECT_NAME when it was run for the same decl. */ ++ ++ #define ASM_FINISH_DECLARE_OBJECT(FILE, DECL, TOP_LEVEL, AT_END) \ ++ do { \ ++ char *name = XSTR (XEXP (DECL_RTL (DECL), 0), 0); \ ++ if (!flag_inhibit_size_directive && DECL_SIZE (DECL) \ ++ && ! AT_END && TOP_LEVEL \ ++ && DECL_INITIAL (DECL) == error_mark_node \ ++ && !size_directive_output) \ ++ { \ ++ size_directive_output = 1; \ ++ fprintf (FILE, "\t%s\t ", SIZE_ASM_OP); \ ++ assemble_name (FILE, name); \ ++ fprintf (FILE, ",%d\n", int_size_in_bytes (TREE_TYPE (DECL))); \ ++ } \ ++ } while (0) ++ ++ /* A table of bytes codes used by the ASM_OUTPUT_ASCII and ++ ASM_OUTPUT_LIMITED_STRING macros. Each byte in the table ++ corresponds to a particular byte value [0..255]. For any ++ given byte value, if the value in the corresponding table ++ position is zero, the given character can be output directly. ++ If the table value is 1, the byte must be output as a \ooo ++ octal escape. If the tables value is anything else, then the ++ byte value should be output as a \ followed by the value ++ in the table. Note that we can use standard UN*X escape ++ sequences for many control characters, but we don't use ++ \a to represent BEL because some svr4 assemblers (e.g. on ++ the i386) don't know about that. Also, we don't use \v ++ since some versions of gas, such as 2.2 did not accept it. */ ++ ++ #define ESCAPES \ ++ "\1\1\1\1\1\1\1\1btn\1fr\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\ ++ \0\0\"\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\ ++ \0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\\\0\0\0\ ++ \0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\1\ ++ \1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\ ++ \1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\ ++ \1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\ ++ \1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1\1" ++ ++ /* Some svr4 assemblers have a limit on the number of characters which ++ can appear in the operand of a .string directive. If your assembler ++ has such a limitation, you should define STRING_LIMIT to reflect that ++ limit. Note that at least some svr4 assemblers have a limit on the ++ actual number of bytes in the double-quoted string, and that they ++ count each character in an escape sequence as one byte. Thus, an ++ escape sequence like \377 would count as four bytes. ++ ++ If your target assembler doesn't support the .string directive, you ++ should define this to zero. ++ */ ++ ++ #define STRING_LIMIT ((unsigned) 256) ++ ++ #define STRING_ASM_OP ".string" ++ ++ /* ++ * We always use gas here, so we don't worry about ECOFF assembler problems. ++ */ ++ #undef TARGET_GAS ++ #define TARGET_GAS (1) ++ ++ #undef PREFERRED_DEBUGGING_TYPE ++ #define PREFERRED_DEBUGGING_TYPE DBX_DEBUG ++ ++ /* Provide a STARTFILE_SPEC appropriate for Linux. Here we add ++ the Linux magical crtbegin.o file (see crtstuff.c) which ++ provides part of the support for getting C++ file-scope static ++ object constructed before entering `main'. */ ++ ++ #undef STARTFILE_SPEC ++ #define STARTFILE_SPEC \ ++ "%{!shared: \ ++ %{pg:gcrt1.o%s} %{!pg:%{p:gcrt1.o%s} %{!p:crt1.o%s}}}\ ++ crti.o%s crtbegin.o%s" ++ ++ /* Provide a ENDFILE_SPEC appropriate for Linux. Here we tack on ++ the Linux magical crtend.o file (see crtstuff.c) which ++ provides part of the support for getting C++ file-scope static ++ object constructed before entering `main', followed by a normal ++ Linux "finalizer" file, `crtn.o'. */ ++ ++ #undef ENDFILE_SPEC ++ #define ENDFILE_SPEC \ ++ "crtend.o%s crtn.o%s" +diff -rcp2N gcc-2.7.2.2/config/alpha/linux.h g77-new/config/alpha/linux.h +*** gcc-2.7.2.2/config/alpha/linux.h Wed Dec 31 19:00:00 1969 +--- g77-new/config/alpha/linux.h Thu Jul 10 20:08:49 1997 +*************** +*** 0 **** +--- 1,72 ---- ++ /* Definitions of target machine for GNU compiler, for Alpha Linux, ++ using ECOFF. ++ Copyright (C) 1995 Free Software Foundation, Inc. ++ Contributed by Bob Manson. ++ Derived from work contributed by Cygnus Support, ++ (c) 1993 Free Software Foundation. ++ ++ This file is part of GNU CC. ++ ++ GNU CC is free software; you can redistribute it and/or modify ++ it under the terms of the GNU General Public License as published by ++ the Free Software Foundation; either version 2, or (at your option) ++ any later version. ++ ++ GNU CC is distributed in the hope that it will be useful, ++ but WITHOUT ANY WARRANTY; without even the implied warranty of ++ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ++ GNU General Public License for more details. ++ ++ You should have received a copy of the GNU General Public License ++ along with GNU CC; see the file COPYING. If not, write to ++ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ ++ ++ #define TARGET_DEFAULT (3 | MASK_GAS) ++ ++ #include "alpha/alpha.h" ++ ++ #undef TARGET_VERSION ++ #define TARGET_VERSION fprintf (stderr, " (Linux/Alpha)"); ++ ++ #undef CPP_PREDEFINES ++ #define CPP_PREDEFINES "\ ++ -D__alpha -D__alpha__ -D__linux__ -D__linux -D_LONGLONG -Dlinux -Dunix \ ++ -Asystem(linux) -Acpu(alpha) -Amachine(alpha)" ++ ++ /* We don't actually need any of these; the MD_ vars are ignored ++ anyway for cross-compilers, and the other specs won't get picked up ++ 'coz the user is supposed to do ld -r (hmm, perhaps that should be ++ the default). In any case, setting them thus will catch some ++ common user errors. */ ++ ++ #undef MD_EXEC_PREFIX ++ #undef MD_STARTFILE_PREFIX ++ ++ #undef LIB_SPEC ++ #define LIB_SPEC "%{pg:-lgmon} %{pg:-lc_p} %{!pg:-lc}" ++ ++ #undef LINK_SPEC ++ #define LINK_SPEC \ ++ "-G 8 %{O*:-O3} %{!O*:-O1}" ++ ++ #undef ASM_SPEC ++ #define ASM_SPEC "-nocpp" ++ ++ /* Can't do stabs */ ++ #undef SDB_DEBUGGING_INFO ++ ++ /* Prefer dbx. */ ++ #undef PREFERRED_DEBUGGING_TYPE ++ #define PREFERRED_DEBUGGING_TYPE DBX_DEBUG ++ ++ #undef FUNCTION_PROFILER ++ ++ #define FUNCTION_PROFILER(FILE, LABELNO) \ ++ do { \ ++ fputs ("\tlda $27,_mcount\n", (FILE)); \ ++ fputs ("\tjsr $26,($27),_mcount\n", (FILE)); \ ++ fputs ("\tldgp $29,0($26)\n", (FILE)); \ ++ } while (0); ++ ++ /* Generate calls to memcpy, etc., not bcopy, etc. */ ++ #define TARGET_MEM_FUNCTIONS +diff -rcp2N gcc-2.7.2.2/config/alpha/t-linux g77-new/config/alpha/t-linux +*** gcc-2.7.2.2/config/alpha/t-linux Wed Dec 31 19:00:00 1969 +--- g77-new/config/alpha/t-linux Thu Jul 10 20:08:49 1997 +*************** +*** 0 **** +--- 1,3 ---- ++ # Our header files are supposed to be correct, nein? ++ FIXINCLUDES = ++ STMP_FIXPROTO = +diff -rcp2N gcc-2.7.2.2/config/alpha/x-linux g77-new/config/alpha/x-linux +*** gcc-2.7.2.2/config/alpha/x-linux Wed Dec 31 19:00:00 1969 +--- g77-new/config/alpha/x-linux Thu Jul 10 20:08:49 1997 +*************** +*** 0 **** +--- 1 ---- ++ CLIB=-lbfd -liberty +diff -rcp2N gcc-2.7.2.2/config/alpha/xm-alpha.h g77-new/config/alpha/xm-alpha.h +*** gcc-2.7.2.2/config/alpha/xm-alpha.h Thu Aug 31 17:52:27 1995 +--- g77-new/config/alpha/xm-alpha.h Thu Jul 10 20:08:49 1997 +*************** Boston, MA 02111-1307, USA. */ +*** 46,51 **** +--- 46,53 ---- + #include + #else ++ #ifndef alloca + extern void *alloca (); + #endif ++ #endif + + /* The host compiler has problems with enum bitfields since it makes +*************** extern void *malloc (), *realloc (), *ca +*** 68,72 **** +--- 70,76 ---- + /* OSF/1 has vprintf. */ + ++ #ifndef linux /* 1996/02/22 mauro@craftwork.com -- unreliable with Linux */ + #define HAVE_VPRINTF ++ #endif + + /* OSF/1 has putenv. */ +diff -rcp2N gcc-2.7.2.2/config/alpha/xm-linux.h g77-new/config/alpha/xm-linux.h +*** gcc-2.7.2.2/config/alpha/xm-linux.h Wed Dec 31 19:00:00 1969 +--- g77-new/config/alpha/xm-linux.h Thu Jul 10 20:08:49 1997 +*************** +*** 0 **** +--- 1,10 ---- ++ #ifndef _XM_LINUX_H ++ #define _XM_LINUX_H ++ ++ #include "xm-alpha.h" ++ ++ #define HAVE_STRERROR ++ ++ #define DONT_DECLARE_SYS_SIGLIST ++ #define USE_BFD ++ #endif +diff -rcp2N gcc-2.7.2.2/config/i386/i386.c g77-new/config/i386/i386.c +*** gcc-2.7.2.2/config/i386/i386.c Sun Oct 22 07:13:21 1995 +--- g77-new/config/i386/i386.c Sun Aug 10 18:46:09 1997 +*************** standard_80387_constant_p (x) +*** 1290,1294 **** + set_float_handler (handler); + REAL_VALUE_FROM_CONST_DOUBLE (d, x); +! is0 = REAL_VALUES_EQUAL (d, dconst0); + is1 = REAL_VALUES_EQUAL (d, dconst1); + set_float_handler (NULL_PTR); +--- 1290,1294 ---- + set_float_handler (handler); + REAL_VALUE_FROM_CONST_DOUBLE (d, x); +! is0 = REAL_VALUES_EQUAL (d, dconst0) && !REAL_VALUE_MINUS_ZERO (d); + is1 = REAL_VALUES_EQUAL (d, dconst1); + set_float_handler (NULL_PTR); +diff -rcp2N gcc-2.7.2.2/config/mips/mips.c g77-new/config/mips/mips.c +*** gcc-2.7.2.2/config/mips/mips.c Thu Feb 20 19:24:13 1997 +--- g77-new/config/mips/mips.c Sun Aug 10 18:45:43 1997 +*************** expand_block_move (operands) +*** 2360,2365 **** + + else if (constp && bytes <= 2*MAX_MOVE_BYTES) +! emit_insn (gen_movstrsi_internal (gen_rtx (MEM, BLKmode, dest_reg), +! gen_rtx (MEM, BLKmode, src_reg), + bytes_rtx, align_rtx)); + +--- 2360,2367 ---- + + else if (constp && bytes <= 2*MAX_MOVE_BYTES) +! emit_insn (gen_movstrsi_internal (change_address (operands[0], +! BLKmode, dest_reg), +! change_address (orig_src, BLKmode, +! src_reg), + bytes_rtx, align_rtx)); + +diff -rcp2N gcc-2.7.2.2/config/mips/mips.h g77-new/config/mips/mips.h +*** gcc-2.7.2.2/config/mips/mips.h Thu Nov 9 11:23:09 1995 +--- g77-new/config/mips/mips.h Sun Aug 10 18:46:44 1997 +*************** typedef struct mips_args { +*** 2160,2170 **** + } \ + \ +! /* Flush the instruction cache. */ \ +! /* ??? Are the modes right? Maybe they should depend on -mint64/-mlong64? */\ + /* ??? Should check the return value for errors. */ \ +! emit_library_call (gen_rtx (SYMBOL_REF, Pmode, "cacheflush"), \ + 0, VOIDmode, 3, addr, Pmode, \ + GEN_INT (TRAMPOLINE_SIZE), SImode, \ +! GEN_INT (1), SImode); \ + } + +--- 2160,2170 ---- + } \ + \ +! /* Flush both caches. We need to flush the data cache in case \ +! the system has a write-back cache. */ \ + /* ??? Should check the return value for errors. */ \ +! emit_library_call (gen_rtx (SYMBOL_REF, Pmode, "_flush_cache"), \ + 0, VOIDmode, 3, addr, Pmode, \ + GEN_INT (TRAMPOLINE_SIZE), SImode, \ +! GEN_INT (3), TYPE_MODE (integer_type_node)); \ + } + +*************** typedef struct mips_args { +*** 2388,2392 **** + ((GET_CODE (X) != CONST_DOUBLE \ + || mips_const_double_ok (X, GET_MODE (X))) \ +! && ! (GET_CODE (X) == CONST && ABI_64BIT)) + + /* A C compound statement that attempts to replace X with a valid +--- 2388,2393 ---- + ((GET_CODE (X) != CONST_DOUBLE \ + || mips_const_double_ok (X, GET_MODE (X))) \ +! && ! (GET_CODE (X) == CONST \ +! && (ABI_64BIT || GET_CODE (XEXP (X, 0)) == MINUS))) + + /* A C compound statement that attempts to replace X with a valid +diff -rcp2N gcc-2.7.2.2/config/mips/sni-gas.h g77-new/config/mips/sni-gas.h +*** gcc-2.7.2.2/config/mips/sni-gas.h Wed Dec 31 19:00:00 1969 +--- g77-new/config/mips/sni-gas.h Sun Aug 10 18:46:33 1997 +*************** +*** 0 **** +--- 1,43 ---- ++ #include "mips/sni-svr4.h" ++ ++ /* Enable debugging. */ ++ #define DBX_DEBUGGING_INFO ++ #define SDB_DEBUGGING_INFO ++ #define MIPS_DEBUGGING_INFO ++ ++ #define DWARF_DEBUGGING_INFO ++ #undef PREFERRED_DEBUGGING_TYPE ++ #define PREFERRED_DEBUGGING_TYPE DWARF_DEBUG ++ ++ /* We need to use .esize and .etype instead of .size and .type to ++ avoid conflicting with ELF directives. These are only recognized ++ by gas, anyhow, not the native assembler. */ ++ #undef PUT_SDB_SIZE ++ #define PUT_SDB_SIZE(a) \ ++ do { \ ++ extern FILE *asm_out_text_file; \ ++ fprintf (asm_out_text_file, "\t.esize\t%d;", (a)); \ ++ } while (0) ++ ++ #undef PUT_SDB_TYPE ++ #define PUT_SDB_TYPE(a) \ ++ do { \ ++ extern FILE *asm_out_text_file; \ ++ fprintf (asm_out_text_file, "\t.etype\t0x%x;", (a)); \ ++ } while (0) ++ ++ ++ /* This is how to equate one symbol to another symbol. The syntax used is ++ `SYM1=SYM2'. Note that this is different from the way equates are done ++ with most svr4 assemblers, where the syntax is `.set SYM1,SYM2'. */ ++ ++ #define ASM_OUTPUT_DEF(FILE,LABEL1,LABEL2) \ ++ do { fprintf ((FILE), "\t"); \ ++ assemble_name (FILE, LABEL1); \ ++ fprintf (FILE, " = "); \ ++ assemble_name (FILE, LABEL2); \ ++ fprintf (FILE, "\n"); \ ++ } while (0) ++ ++ ++ +diff -rcp2N gcc-2.7.2.2/config/mips/sni-svr4.h g77-new/config/mips/sni-svr4.h +*** gcc-2.7.2.2/config/mips/sni-svr4.h Wed Dec 31 19:00:00 1969 +--- g77-new/config/mips/sni-svr4.h Sun Aug 10 18:46:33 1997 +*************** +*** 0 **** +--- 1,103 ---- ++ /* Definitions of target machine for GNU compiler. SNI SINIX version. ++ Copyright (C) 1996 Free Software Foundation, Inc. ++ Contributed by Marco Walther (Marco.Walther@mch.sni.de). ++ ++ This file is part of GNU CC. ++ ++ GNU CC is free software; you can redistribute it and/or modify ++ it under the terms of the GNU General Public License as published by ++ the Free Software Foundation; either version 2, or (at your option) ++ any later version. ++ ++ GNU CC is distributed in the hope that it will be useful, ++ but WITHOUT ANY WARRANTY; without even the implied warranty of ++ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ++ GNU General Public License for more details. ++ ++ You should have received a copy of the GNU General Public License ++ along with GNU CC; see the file COPYING. If not, write to ++ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ ++ ++ #define MIPS_SVR4 ++ ++ #define CPP_PREDEFINES "\ ++ -Dmips -Dunix -Dhost_mips -DMIPSEB -DR3000 -DSYSTYPE_SVR4 \ ++ -D_mips -D_unix -D_host_mips -D_MIPSEB -D_R3000 -D_SYSTYPE_SVR4 \ ++ -Asystem(unix) -Asystem(svr4) -Acpu(mips) -Amachine(mips)" ++ ++ #define CPP_SPEC "\ ++ %{.cc: -D__LANGUAGE_C_PLUS_PLUS -D_LANGUAGE_C_PLUS_PLUS} \ ++ %{.cxx: -D__LANGUAGE_C_PLUS_PLUS -D_LANGUAGE_C_PLUS_PLUS} \ ++ %{.C: -D__LANGUAGE_C_PLUS_PLUS -D_LANGUAGE_C_PLUS_PLUS} \ ++ %{.m: -D__LANGUAGE_OBJECTIVE_C -D_LANGUAGE_OBJECTIVE_C} \ ++ %{.S: -D__LANGUAGE_ASSEMBLY -D_LANGUAGE_ASSEMBLY %{!ansi:-DLANGUAGE_ASSEMBLY}} \ ++ %{.s: -D__LANGUAGE_ASSEMBLY -D_LANGUAGE_ASSEMBLY %{!ansi:-DLANGUAGE_ASSEMBLY}} \ ++ %{!.S:%{!.s: -D__LANGUAGE_C -D_LANGUAGE_C %{!ansi:-DLANGUAGE_C}}} \ ++ -D__SIZE_TYPE__=unsigned\\ int -D__PTRDIFF_TYPE__=int" ++ ++ #define LINK_SPEC "\ ++ %{G*} \ ++ %{!mgas: \ ++ %{dy} %{dn}}" ++ ++ #define LIB_SPEC "\ ++ %{p:-lprof1} \ ++ %{!p:%{pg:-lprof1} \ ++ %{!pg:-L/usr/ccs/lib/ -lc /usr/ccs/lib/crtn.o%s}}" ++ ++ #define STARTFILE_SPEC "\ ++ %{pg:gcrt0.o%s} \ ++ %{!pg:%{p:mcrt0.o%s} \ ++ %{!p:/usr/ccs/lib/crt1.o /usr/ccs/lib/crti.o /usr/ccs/lib/values-Xt.o%s}}" ++ ++ /* Mips System V.4 doesn't have a getpagesize() function needed by the ++ trampoline code, so use the POSIX sysconf function to get it. ++ This is only done when compiling the trampoline code. */ ++ ++ #ifdef L_trampoline ++ #include ++ ++ #define getpagesize() sysconf(_SC_PAGE_SIZE) ++ #endif /* L_trampoline */ ++ ++ /* Use atexit for static constructors/destructors, instead of defining ++ our own exit function. */ ++ #define HAVE_ATEXIT ++ ++ /* Generate calls to memcpy, etc., not bcopy, etc. */ ++ #define TARGET_MEM_FUNCTIONS ++ ++ #define OBJECT_FORMAT_ELF ++ ++ #define TARGET_DEFAULT MASK_ABICALLS ++ #define ABICALLS_ASM_OP ".option pic2" ++ ++ #define MACHINE_TYPE "SNI running SINIX 5.42" ++ ++ #define MIPS_DEFAULT_GVALUE 0 ++ ++ #define NM_FLAGS "-p" ++ ++ /* wir haben ein Problem, wenn in einem Assembler-File keine .text-section ++ erzeugt wird. Dann landen diese Pseudo-Labels in irgendeiner anderen ++ section, z.B. .reginfo. Das macht den ld sehr ungluecklich. */ ++ ++ #define ASM_IDENTIFY_GCC(mw_stream) \ ++ fprintf(mw_stream, "\t.ident \"gcc2_compiled.\"\n"); ++ ++ #define ASM_IDENTIFY_LANGUAGE(STREAM) ++ ++ #define ASM_LONG ".word\t" ++ #define ASM_GLOBAL ".rdata\n\t\t.globl\t" ++ ++ #include "mips/mips.h" ++ ++ /* We do not want to run mips-tfile! */ ++ #undef ASM_FINAL_SPEC ++ ++ #undef OBJECT_FORMAT_COFF ++ ++ /* We don't support debugging info for now. */ ++ #undef DBX_DEBUGGING_INFO ++ #undef SDB_DEBUGGING_INFO ++ #undef MIPS_DEBUGGING_INFO +diff -rcp2N gcc-2.7.2.2/config/mips/x-sni-svr4 g77-new/config/mips/x-sni-svr4 +*** gcc-2.7.2.2/config/mips/x-sni-svr4 Wed Dec 31 19:00:00 1969 +--- g77-new/config/mips/x-sni-svr4 Sun Aug 10 18:46:33 1997 +*************** +*** 0 **** +--- 1,18 ---- ++ # Define CC and OLDCC as the same, so that the tests: ++ # if [ x"$(OLDCC)" = x"$(CC)" ] ... ++ # ++ # will succeed (if OLDCC != CC, it is assumed that GCC is ++ # being used in secondary stage builds). ++ # -Olimit is so the user can use -O2. Down with fixed ++ # size tables! ++ ++ CC = $(OLDCC) ++ OPT = ++ OLDCC = cc -Olimit 3000 $(OPT) ++ ++ X_CFLAGS = -DNO_SYS_SIGLIST ++ ++ # Show we need to use the C version of ALLOCA ++ # The SVR3 configurations have it, but the SVR4 configurations don't. ++ # For now, just try using it for all SVR* configurations. ++ ALLOCA = alloca.o +diff -rcp2N gcc-2.7.2.2/config/msdos/configur.bat g77-new/config/msdos/configur.bat +*** gcc-2.7.2.2/config/msdos/configur.bat Mon Aug 28 05:55:47 1995 +--- g77-new/config/msdos/configur.bat Sun Aug 10 19:08:05 1997 +*************** sed -f config/msdos/top.sed Makefile.in +*** 18,21 **** +--- 18,27 ---- + set LANG= + ++ if not exist ada\make-lang.in goto no_ada ++ sed -f config/msdos/top.sed ada\make-lang.in >> Makefile ++ sed -f config/msdos/top.sed ada\makefile.in > ada\Makefile ++ set LANG=%LANG% ada.& ++ :no_ada ++ + if not exist cp\make-lang.in goto no_cp + sed -f config/msdos/top.sed cp\make-lang.in >> Makefile +diff -rcp2N gcc-2.7.2.2/config/pa/pa.c g77-new/config/pa/pa.c +*** gcc-2.7.2.2/config/pa/pa.c Sun Oct 22 07:45:20 1995 +--- g77-new/config/pa/pa.c Sun Aug 10 18:45:44 1997 +*************** output_move_double (operands) +*** 1344,1369 **** + do them in the other order. + +! RMS says "This happens only for registers; +! such overlap can't happen in memory unless the user explicitly +! sets it up, and that is an undefined circumstance." +! +! but it happens on the HP-PA when loading parameter registers, +! so I am going to define that circumstance, and make it work +! as expected. */ + +! if (optype0 == REGOP && (optype1 == MEMOP || optype1 == OFFSOP) +! && reg_overlap_mentioned_p (operands[0], XEXP (operands[1], 0))) + { +- /* XXX THIS PROBABLY DOESN'T WORK. */ + /* Do the late half first. */ + if (addreg1) + output_asm_insn ("ldo 4(%0),%0", &addreg1); + output_asm_insn (singlemove_string (latehalf), latehalf); + if (addreg1) + output_asm_insn ("ldo -4(%0),%0", &addreg1); +- /* Then clobber. */ + return singlemove_string (operands); + } + + if (optype0 == REGOP && optype1 == REGOP + && REGNO (operands[0]) == REGNO (operands[1]) + 1) +--- 1344,1377 ---- + do them in the other order. + +! This can happen in two cases: + +! mem -> register where the first half of the destination register +! is the same register used in the memory's address. Reload +! can create such insns. +! +! mem in this case will be either register indirect or register +! indirect plus a valid offset. +! +! register -> register move where REGNO(dst) == REGNO(src + 1) +! someone (Tim/Tege?) claimed this can happen for parameter loads. +! +! Handle mem -> register case first. */ +! if (optype0 == REGOP +! && (optype1 == MEMOP || optype1 == OFFSOP) +! && refers_to_regno_p (REGNO (operands[0]), REGNO (operands[0]) + 1, +! operands[1], 0)) + { + /* Do the late half first. */ + if (addreg1) + output_asm_insn ("ldo 4(%0),%0", &addreg1); + output_asm_insn (singlemove_string (latehalf), latehalf); ++ ++ /* Then clobber. */ + if (addreg1) + output_asm_insn ("ldo -4(%0),%0", &addreg1); + return singlemove_string (operands); + } + ++ /* Now handle register -> register case. */ + if (optype0 == REGOP && optype1 == REGOP + && REGNO (operands[0]) == REGNO (operands[1]) + 1) +diff -rcp2N gcc-2.7.2.2/config/pa/pa.md g77-new/config/pa/pa.md +*** gcc-2.7.2.2/config/pa/pa.md Mon Aug 14 09:00:49 1995 +--- g77-new/config/pa/pa.md Sun Aug 10 18:45:45 1997 +*************** +*** 1828,1832 **** + (define_insn "" + [(set (match_operand:DF 0 "reg_or_nonsymb_mem_operand" +! "=f,*r,Q,?o,?Q,f,*&r,*&r") + (match_operand:DF 1 "reg_or_0_or_nonsymb_mem_operand" + "fG,*rG,f,*r,*r,Q,o,Q"))] +--- 1828,1832 ---- + (define_insn "" + [(set (match_operand:DF 0 "reg_or_nonsymb_mem_operand" +! "=f,*r,Q,?o,?Q,f,*r,*r") + (match_operand:DF 1 "reg_or_0_or_nonsymb_mem_operand" + "fG,*rG,f,*r,*r,Q,o,Q"))] +*************** +*** 1846,1850 **** + (define_insn "" + [(set (match_operand:DF 0 "reg_or_nonsymb_mem_operand" +! "=r,?o,?Q,&r,&r") + (match_operand:DF 1 "reg_or_0_or_nonsymb_mem_operand" + "rG,r,r,o,Q"))] +--- 1846,1850 ---- + (define_insn "" + [(set (match_operand:DF 0 "reg_or_nonsymb_mem_operand" +! "=r,?o,?Q,r,r") + (match_operand:DF 1 "reg_or_0_or_nonsymb_mem_operand" + "rG,r,r,o,Q"))] +*************** +*** 2019,2023 **** + (define_insn "" + [(set (match_operand:DI 0 "reg_or_nonsymb_mem_operand" +! "=r,o,Q,&r,&r,&r,f,f,*T") + (match_operand:DI 1 "general_operand" + "rM,r,r,o,Q,i,fM,*T,f"))] +--- 2019,2023 ---- + (define_insn "" + [(set (match_operand:DI 0 "reg_or_nonsymb_mem_operand" +! "=r,o,Q,r,r,r,f,f,*T") + (match_operand:DI 1 "general_operand" + "rM,r,r,o,Q,i,fM,*T,f"))] +*************** +*** 2037,2041 **** + (define_insn "" + [(set (match_operand:DI 0 "reg_or_nonsymb_mem_operand" +! "=r,o,Q,&r,&r,&r") + (match_operand:DI 1 "general_operand" + "rM,r,r,o,Q,i"))] +--- 2037,2041 ---- + (define_insn "" + [(set (match_operand:DI 0 "reg_or_nonsymb_mem_operand" +! "=r,o,Q,r,r,r") + (match_operand:DI 1 "general_operand" + "rM,r,r,o,Q,i"))] +diff -rcp2N gcc-2.7.2.2/config/rs6000/rs6000.c g77-new/config/rs6000/rs6000.c +*** gcc-2.7.2.2/config/rs6000/rs6000.c Thu Feb 20 19:24:14 1997 +--- g77-new/config/rs6000/rs6000.c Sun Aug 10 04:44:05 1997 +*************** input_operand (op, mode) +*** 724,730 **** + return 1; + +! /* For HImode and QImode, any constant is valid. */ +! if ((mode == HImode || mode == QImode) +! && GET_CODE (op) == CONST_INT) + return 1; + +--- 724,729 ---- + return 1; + +! /* For integer modes, any constant is ok. */ +! if (GET_CODE (op) == CONST_INT) + return 1; + +diff -rcp2N gcc-2.7.2.2/config/sparc/sol2.h g77-new/config/sparc/sol2.h +*** gcc-2.7.2.2/config/sparc/sol2.h Sat Aug 19 17:36:45 1995 +--- g77-new/config/sparc/sol2.h Sun Aug 10 18:45:53 1997 +*************** do { \ +*** 166,168 **** + /* Define for support of TFmode long double and REAL_ARITHMETIC. + Sparc ABI says that long double is 4 words. */ +! #define LONG_DOUBLE_TYPE_SIZE 128 +--- 166,168 ---- + /* Define for support of TFmode long double and REAL_ARITHMETIC. + Sparc ABI says that long double is 4 words. */ +! #define LONG_DOUBLE_TYPE_SIZE 64 +diff -rcp2N gcc-2.7.2.2/config/sparc/sparc.c g77-new/config/sparc/sparc.c +*** gcc-2.7.2.2/config/sparc/sparc.c Tue Sep 12 18:32:24 1995 +--- g77-new/config/sparc/sparc.c Sun Aug 10 18:46:03 1997 +*************** Boston, MA 02111-1307, USA. */ +*** 40,46 **** + /* 1 if the caller has placed an "unimp" insn immediately after the call. + This is used in v8 code when calling a function that returns a structure. +! v9 doesn't have this. */ + +! #define SKIP_CALLERS_UNIMP_P (!TARGET_V9 && current_function_returns_struct) + + /* Global variables for machine-dependent things. */ +--- 40,51 ---- + /* 1 if the caller has placed an "unimp" insn immediately after the call. + This is used in v8 code when calling a function that returns a structure. +! v9 doesn't have this. Be careful to have this test be the same as that +! used on the call. */ + +! #define SKIP_CALLERS_UNIMP_P \ +! (!TARGET_V9 && current_function_returns_struct \ +! && ! integer_zerop (DECL_SIZE (DECL_RESULT (current_function_decl))) \ +! && (TREE_CODE (DECL_SIZE (DECL_RESULT (current_function_decl))) \ +! == INTEGER_CST)) + + /* Global variables for machine-dependent things. */ +diff -rcp2N gcc-2.7.2.2/config/sparc/sparc.h g77-new/config/sparc/sparc.h +*** gcc-2.7.2.2/config/sparc/sparc.h Thu Feb 20 19:24:15 1997 +--- g77-new/config/sparc/sparc.h Sun Aug 10 18:46:13 1997 +*************** extern int leaf_function; +*** 1526,1533 **** + + /* Output assembler code to FILE to increment profiler label # LABELNO +! for profiling a function entry. */ + + #define FUNCTION_PROFILER(FILE, LABELNO) \ + do { \ + fputs ("\tsethi %hi(", (FILE)); \ + ASM_OUTPUT_INTERNAL_LABELREF (FILE, "LP", LABELNO); \ +--- 1526,1540 ---- + + /* Output assembler code to FILE to increment profiler label # LABELNO +! for profiling a function entry. +! +! 32 bit sparc uses %g2 as the STATIC_CHAIN_REGNUM which gets clobbered +! during profiling so we need to save/restore it around the call to mcount. +! We're guaranteed that a save has just been done, and we use the space +! allocated for intreg/fpreg value passing. */ + + #define FUNCTION_PROFILER(FILE, LABELNO) \ + do { \ ++ if (! TARGET_V9) \ ++ fputs ("\tst %g2,[%fp-4]\n", FILE); \ + fputs ("\tsethi %hi(", (FILE)); \ + ASM_OUTPUT_INTERNAL_LABELREF (FILE, "LP", LABELNO); \ +*************** extern int leaf_function; +*** 1539,1542 **** +--- 1546,1551 ---- + ASM_OUTPUT_INTERNAL_LABELREF (FILE, "LP", LABELNO); \ + fputs ("),%o0,%o0\n", (FILE)); \ ++ if (! TARGET_V9) \ ++ fputs ("\tld [%fp-4],%g2\n", FILE); \ + } while (0) + +diff -rcp2N gcc-2.7.2.2/config/sparc/sparc.md g77-new/config/sparc/sparc.md +*** gcc-2.7.2.2/config/sparc/sparc.md Tue Sep 12 18:57:35 1995 +--- g77-new/config/sparc/sparc.md Sun Aug 10 18:46:27 1997 +*************** +*** 4799,4803 **** + abort (); + +! if (GET_CODE (XEXP (operands[0], 0)) == LABEL_REF) + { + /* This is really a PIC sequence. We want to represent +--- 4799,4803 ---- + abort (); + +! if (GET_CODE (XEXP (operands[0], 0)) == LABEL_REF) + { + /* This is really a PIC sequence. We want to represent +*************** +*** 4809,4824 **** + + if (! TARGET_V9 && INTVAL (operands[3]) != 0) +! emit_jump_insn (gen_rtx (PARALLEL, VOIDmode, gen_rtvec (3, +! gen_rtx (SET, VOIDmode, pc_rtx, +! XEXP (operands[0], 0)), +! operands[3], +! gen_rtx (CLOBBER, VOIDmode, +! gen_rtx (REG, Pmode, 15))))); + else +! emit_jump_insn (gen_rtx (PARALLEL, VOIDmode, gen_rtvec (2, +! gen_rtx (SET, VOIDmode, pc_rtx, +! XEXP (operands[0], 0)), +! gen_rtx (CLOBBER, VOIDmode, +! gen_rtx (REG, Pmode, 15))))); + goto finish_call; + } +--- 4809,4828 ---- + + if (! TARGET_V9 && INTVAL (operands[3]) != 0) +! emit_jump_insn +! (gen_rtx (PARALLEL, VOIDmode, +! gen_rtvec (3, +! gen_rtx (SET, VOIDmode, pc_rtx, +! XEXP (operands[0], 0)), +! GEN_INT (INTVAL (operands[3]) & 0xfff), +! gen_rtx (CLOBBER, VOIDmode, +! gen_rtx (REG, Pmode, 15))))); + else +! emit_jump_insn +! (gen_rtx (PARALLEL, VOIDmode, +! gen_rtvec (2, +! gen_rtx (SET, VOIDmode, pc_rtx, +! XEXP (operands[0], 0)), +! gen_rtx (CLOBBER, VOIDmode, +! gen_rtx (REG, Pmode, 15))))); + goto finish_call; + } +*************** +*** 4839,4852 **** + + if (! TARGET_V9 && INTVAL (operands[3]) != 0) +! emit_call_insn (gen_rtx (PARALLEL, VOIDmode, gen_rtvec (3, +! gen_rtx (CALL, VOIDmode, fn_rtx, nregs_rtx), +! operands[3], +! gen_rtx (CLOBBER, VOIDmode, +! gen_rtx (REG, Pmode, 15))))); + else +! emit_call_insn (gen_rtx (PARALLEL, VOIDmode, gen_rtvec (2, +! gen_rtx (CALL, VOIDmode, fn_rtx, nregs_rtx), +! gen_rtx (CLOBBER, VOIDmode, +! gen_rtx (REG, Pmode, 15))))); + + finish_call: +--- 4843,4858 ---- + + if (! TARGET_V9 && INTVAL (operands[3]) != 0) +! emit_call_insn +! (gen_rtx (PARALLEL, VOIDmode, +! gen_rtvec (3, gen_rtx (CALL, VOIDmode, fn_rtx, nregs_rtx), +! GEN_INT (INTVAL (operands[3]) & 0xfff), +! gen_rtx (CLOBBER, VOIDmode, +! gen_rtx (REG, Pmode, 15))))); + else +! emit_call_insn +! (gen_rtx (PARALLEL, VOIDmode, +! gen_rtvec (2, gen_rtx (CALL, VOIDmode, fn_rtx, nregs_rtx), +! gen_rtx (CLOBBER, VOIDmode, +! gen_rtx (REG, Pmode, 15))))); + + finish_call: +*************** +*** 4911,4915 **** + (clobber (reg:SI 15))] + ;;- Do not use operand 1 for most machines. +! "! TARGET_V9 && GET_CODE (operands[2]) == CONST_INT && INTVAL (operands[2]) > 0" + "call %a0,%1\;nop\;unimp %2" + [(set_attr "type" "call_no_delay_slot")]) +--- 4917,4921 ---- + (clobber (reg:SI 15))] + ;;- Do not use operand 1 for most machines. +! "! TARGET_V9 && GET_CODE (operands[2]) == CONST_INT && INTVAL (operands[2]) >= 0" + "call %a0,%1\;nop\;unimp %2" + [(set_attr "type" "call_no_delay_slot")]) +*************** +*** 4923,4927 **** + (clobber (reg:SI 15))] + ;;- Do not use operand 1 for most machines. +! "! TARGET_V9 && GET_CODE (operands[2]) == CONST_INT && INTVAL (operands[2]) > 0" + "call %a0,%1\;nop\;unimp %2" + [(set_attr "type" "call_no_delay_slot")]) +--- 4929,4933 ---- + (clobber (reg:SI 15))] + ;;- Do not use operand 1 for most machines. +! "! TARGET_V9 && GET_CODE (operands[2]) == CONST_INT && INTVAL (operands[2]) >= 0" + "call %a0,%1\;nop\;unimp %2" + [(set_attr "type" "call_no_delay_slot")]) +*************** +*** 5178,5184 **** + emit_insn (gen_rtx (USE, VOIDmode, stack_pointer_rtx)); + emit_insn (gen_rtx (USE, VOIDmode, static_chain_rtx)); +- emit_insn (gen_rtx (USE, VOIDmode, gen_rtx (REG, Pmode, 8))); + /* Return, restoring reg window and jumping to goto handler. */ + emit_insn (gen_goto_handler_and_restore ()); + DONE; + }") +--- 5184,5190 ---- + emit_insn (gen_rtx (USE, VOIDmode, stack_pointer_rtx)); + emit_insn (gen_rtx (USE, VOIDmode, static_chain_rtx)); + /* Return, restoring reg window and jumping to goto handler. */ + emit_insn (gen_goto_handler_and_restore ()); ++ emit_barrier (); + DONE; + }") +*************** +*** 5192,5200 **** + + (define_insn "goto_handler_and_restore" +! [(unspec_volatile [(const_int 0)] 2)] + "" + "jmp %%o0+0\;restore" + [(set_attr "type" "misc") + (set_attr "length" "2")]) + + ;; Special pattern for the FLUSH instruction. +--- 5198,5237 ---- + + (define_insn "goto_handler_and_restore" +! [(unspec_volatile [(const_int 0)] 2) +! (use (reg:SI 8))] + "" + "jmp %%o0+0\;restore" + [(set_attr "type" "misc") + (set_attr "length" "2")]) ++ ++ ;; Pattern for use after a setjmp to store FP and the return register ++ ;; into the stack area. ++ ++ (define_expand "setjmp" ++ [(const_int 0)] ++ "" ++ " ++ { ++ if (TARGET_V9) ++ emit_insn (gen_setjmp_64 ()); ++ else ++ emit_insn (gen_setjmp_32 ()); ++ ++ DONE; ++ }") ++ ++ (define_expand "setjmp_32" ++ [(set (mem:SI (plus:SI (reg:SI 14) (const_int 56))) (match_dup 0)) ++ (set (mem:SI (plus:SI (reg:SI 14) (const_int 60))) (reg:SI 31))] ++ "" ++ " ++ { operands[0] = frame_pointer_rtx; }") ++ ++ (define_expand "setjmp_64" ++ [(set (mem:DI (plus:DI (reg:DI 14) (const_int 112))) (match_dup 0)) ++ (set (mem:DI (plus:DI (reg:DI 14) (const_int 120))) (reg:DI 31))] ++ "" ++ " ++ { operands[0] = frame_pointer_rtx; }") + + ;; Special pattern for the FLUSH instruction. +diff -rcp2N gcc-2.7.2.2/config/x-linux g77-new/config/x-linux +*** gcc-2.7.2.2/config/x-linux Tue Mar 28 07:43:37 1995 +--- g77-new/config/x-linux Thu Jul 10 20:08:49 1997 +*************** BOOT_CFLAGS = -O $(CFLAGS) -Iinclude +*** 13,14 **** +--- 13,17 ---- + # Don't run fixproto + STMP_FIXPROTO = ++ ++ # Don't install "assert.h" in gcc. We use the one in glibc. ++ INSTALL_ASSERT_H = +diff -rcp2N gcc-2.7.2.2/config/x-linux-aout g77-new/config/x-linux-aout +*** gcc-2.7.2.2/config/x-linux-aout Wed Dec 31 19:00:00 1969 +--- g77-new/config/x-linux-aout Thu Jul 10 20:08:49 1997 +*************** +*** 0 **** +--- 1,14 ---- ++ # It is defined in config/xm-linux.h. ++ # X_CFLAGS = -DPOSIX ++ ++ # The following is needed when compiling stages 2 and 3 because gcc's ++ # limits.h must be picked up before /usr/include/limits.h. This is because ++ # each does an #include_next of the other if the other hasn't been included. ++ # /usr/include/limits.h loses if it gets found first because /usr/include is ++ # at the end of the search order. When a new version of gcc is released, ++ # gcc's limits.h hasn't been installed yet and hence isn't found. ++ ++ BOOT_CFLAGS = -O $(CFLAGS) -Iinclude ++ ++ # Don't run fixproto ++ STMP_FIXPROTO = +diff -rcp2N gcc-2.7.2.2/config.guess g77-new/config.guess +*** gcc-2.7.2.2/config.guess Thu Feb 20 19:24:32 1997 +--- g77-new/config.guess Thu Jul 10 20:08:50 1997 +*************** trap 'rm -f dummy.c dummy.o dummy; exit +*** 52,63 **** + + case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in +- alpha:OSF1:V*:*) +- # After 1.2, OSF1 uses "V1.3" for uname -r. +- echo alpha-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^V//'` +- exit 0 ;; + alpha:OSF1:*:*) + # 1.2 uses "1.2" for uname -r. +! echo alpha-dec-osf${UNAME_RELEASE} +! exit 0 ;; + 21064:Windows_NT:50:3) + echo alpha-dec-winnt3.5 +--- 52,62 ---- + + case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in + alpha:OSF1:*:*) ++ # A Vn.n version is a released version. ++ # A Tn.n version is a released field test version. ++ # A Xn.n version is an unreleased experimental baselevel. + # 1.2 uses "1.2" for uname -r. +! echo alpha-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[VTX]//'` +! exit 0 ;; + 21064:Windows_NT:50:3) + echo alpha-dec-winnt3.5 +*************** case "${UNAME_MACHINE}:${UNAME_SYSTEM}:$ +*** 154,161 **** + echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` + exit 0 ;; +! ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. + echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id + exit 0 ;; # Note that: echo "'`uname -s`'" gives 'AIX ' +! i[34]86:AIX:*:*) + echo i386-ibm-aix + exit 0 ;; +--- 153,160 ---- + echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` + exit 0 ;; +! ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. + echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id + exit 0 ;; # Note that: echo "'`uname -s`'" gives 'AIX ' +! i?86:AIX:*:*) + echo i386-ibm-aix + exit 0 ;; +*************** EOF +*** 220,224 **** + 9000/31? ) HP_ARCH=m68000 ;; + 9000/[34]?? ) HP_ARCH=m68k ;; +! 9000/7?? | 9000/8?[79] ) HP_ARCH=hppa1.1 ;; + 9000/8?? ) HP_ARCH=hppa1.0 ;; + esac +--- 219,223 ---- + 9000/31? ) HP_ARCH=m68000 ;; + 9000/[34]?? ) HP_ARCH=m68k ;; +! 9000/7?? | 9000/8?[1679] ) HP_ARCH=hppa1.1 ;; + 9000/8?? ) HP_ARCH=hppa1.0 ;; + esac +*************** EOF +*** 304,308 **** + echo m68k-hp-netbsd${UNAME_RELEASE} + exit 0 ;; +! i[34]86:BSD/386:*:* | *:BSD/OS:*:*) + echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} + exit 0 ;; +--- 303,307 ---- + echo m68k-hp-netbsd${UNAME_RELEASE} + exit 0 ;; +! i?86:BSD/386:*:* | *:BSD/OS:*:*) + echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} + exit 0 ;; +*************** EOF +*** 314,318 **** + exit 0 ;; + *:GNU:*:*) +! echo `echo ${UNAME_MACHINE}|sed -e 's,/.*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` + exit 0 ;; + *:Linux:*:*) +--- 313,317 ---- + exit 0 ;; + *:GNU:*:*) +! echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` + exit 0 ;; + *:Linux:*:*) +*************** EOF +*** 320,330 **** + # first see if it will tell us. + ld_help_string=`ld --help 2>&1` +! # if echo $ld_help_string | grep >/dev/null 2>&1 "supported emulations: elf_i[345]86"; then + # echo "${UNAME_MACHINE}-unknown-linux" ; exit 0 +! if echo $ld_help_string | grep >/dev/null 2>&1 "supported emulations: i[345]86linux"; then + echo "${UNAME_MACHINE}-unknown-linuxaout" ; exit 0 +! elif echo $ld_help_string | grep >/dev/null 2>&1 "supported emulations: i[345]86coff"; then + echo "${UNAME_MACHINE}-unknown-linuxcoff" ; exit 0 + elif test "${UNAME_MACHINE}" = "alpha" ; then + echo alpha-unknown-linux ; exit 0 + else +--- 319,333 ---- + # first see if it will tell us. + ld_help_string=`ld --help 2>&1` +! # if echo $ld_help_string | grep >/dev/null 2>&1 "supported emulations: elf_i?86"; then + # echo "${UNAME_MACHINE}-unknown-linux" ; exit 0 +! if echo $ld_help_string | grep >/dev/null 2>&1 "supported emulations: i?86linux"; then + echo "${UNAME_MACHINE}-unknown-linuxaout" ; exit 0 +! elif echo $ld_help_string | grep >/dev/null 2>&1 "supported emulations: i?86coff"; then + echo "${UNAME_MACHINE}-unknown-linuxcoff" ; exit 0 + elif test "${UNAME_MACHINE}" = "alpha" ; then ++ as_version_string=`as --version 2>&1` ++ if echo $as_version_string | grep >/dev/null 2>&1 " version 2.6 "; then ++ echo alpha-unknown-linuxoldas ; exit 0 ++ fi + echo alpha-unknown-linux ; exit 0 + else +*************** EOF +*** 363,370 **** + # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. earlier versions + # are messed up and put the nodename in both sysname and nodename. +! i[34]86:DYNIX/ptx:4*:*) + echo i386-sequent-sysv4 + exit 0 ;; +! i[34]86:*:4.*:* | i[34]86:SYSTEM_V:4.*:*) + if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then + echo ${UNAME_MACHINE}-univel-sysv${UNAME_RELEASE} +--- 366,373 ---- + # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. earlier versions + # are messed up and put the nodename in both sysname and nodename. +! i?86:DYNIX/ptx:4*:*) + echo i386-sequent-sysv4 + exit 0 ;; +! i?86:*:4.*:* | i?86:SYSTEM_V:4.*:*) + if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then + echo ${UNAME_MACHINE}-univel-sysv${UNAME_RELEASE} +*************** EOF +*** 373,377 **** + fi + exit 0 ;; +! i[34]86:*:3.2:*) + if test -f /usr/options/cb.name; then + UNAME_REL=`sed -n 's/.*Version //p' /dev/null) && UNAME_MACHINE=i486 ++ (/bin/uname -X|egrep '^Machine.*Pentium' >/dev/null) \ ++ && UNAME_MACHINE=i586 + echo ${UNAME_MACHINE}-unknown-sco$UNAME_REL + else +*************** EOF +*** 402,406 **** + echo m68010-convergent-sysv + exit 0 ;; +! M680[234]0:*:R3V[567]*:*) + test -r /sysV68 && echo 'm68k-motorola-sysv' && exit 0 ;; + 3[34]??:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0) +--- 407,411 ---- + echo m68010-convergent-sysv + exit 0 ;; +! M68*:*:R3V[567]*:*) + test -r /sysV68 && echo 'm68k-motorola-sysv' && exit 0 ;; + 3[34]??:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0) +*************** EOF +*** 410,414 **** + uname -p 2>/dev/null | grep 86 >/dev/null \ + && echo i486-ncr-sysv4 && exit 0 ;; +! m680[234]0:LynxOS:2.[23]*:*) + echo m68k-lynx-lynxos${UNAME_RELEASE} + exit 0 ;; +--- 415,419 ---- + uname -p 2>/dev/null | grep 86 >/dev/null \ + && echo i486-ncr-sysv4 && exit 0 ;; +! m68*:LynxOS:2.*:*) + echo m68k-lynx-lynxos${UNAME_RELEASE} + exit 0 ;; +*************** EOF +*** 416,426 **** + echo m68k-atari-sysv4 + exit 0 ;; +! i[34]86:LynxOS:2.[23]*:*) + echo i386-lynx-lynxos${UNAME_RELEASE} + exit 0 ;; +! TSUNAMI:LynxOS:2.[23]*:*) + echo sparc-lynx-lynxos${UNAME_RELEASE} + exit 0 ;; +! rs6000:LynxOS:2.[23]*:*) + echo rs6000-lynx-lynxos${UNAME_RELEASE} + exit 0 ;; +--- 421,431 ---- + echo m68k-atari-sysv4 + exit 0 ;; +! i?86:LynxOS:2.*:*) + echo i386-lynx-lynxos${UNAME_RELEASE} + exit 0 ;; +! TSUNAMI:LynxOS:2.*:*) + echo sparc-lynx-lynxos${UNAME_RELEASE} + exit 0 ;; +! rs6000:LynxOS:2.*:* | PowerPC:LynxOS:2.*:*) + echo rs6000-lynx-lynxos${UNAME_RELEASE} + exit 0 ;; +*************** main () +*** 479,483 **** + int version; + version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; +! printf ("%s-next-nextstep%s\n", __ARCHITECTURE__, version==2 ? "2" : "3"); + exit (0); + #endif +--- 484,488 ---- + int version; + version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; +! printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); + exit (0); + #endif +diff -rcp2N gcc-2.7.2.2/config.sub g77-new/config.sub +*** gcc-2.7.2.2/config.sub Thu Jun 15 17:01:49 1995 +--- g77-new/config.sub Thu Jul 10 20:08:50 1997 +*************** case $basic_machine in +*** 130,134 **** + # Recognize the basic CPU types without company name. + # Some are omitted here because they have special meanings below. +! tahoe | i[345]86 | i860 | m68k | m68000 | m88k | ns32k | arm \ + | arme[lb] | pyramid \ + | tron | a29k | 580 | i960 | h8300 | hppa1.0 | hppa1.1 \ +--- 130,134 ---- + # Recognize the basic CPU types without company name. + # Some are omitted here because they have special meanings below. +! tahoe | i[3456]86 | i860 | m68k | m68000 | m88k | ns32k | arm \ + | arme[lb] | pyramid \ + | tron | a29k | 580 | i960 | h8300 | hppa1.0 | hppa1.1 \ +*************** case $basic_machine in +*** 145,149 **** + ;; + # Recognize the basic CPU types with company name. +! vax-* | tahoe-* | i[345]86-* | i860-* | m68k-* | m68000-* | m88k-* \ + | sparc-* | ns32k-* | fx80-* | arm-* | c[123]* \ + | mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* | power-* \ +--- 145,149 ---- + ;; + # Recognize the basic CPU types with company name. +! vax-* | tahoe-* | i[3456]86-* | i860-* | m68k-* | m68000-* | m88k-* \ + | sparc-* | ns32k-* | fx80-* | arm-* | c[123]* \ + | mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* | power-* \ +*************** case $basic_machine in +*** 309,325 **** + ;; + # I'm not sure what "Sysv32" means. Should this be sysv3.2? +! i[345]86v32) + basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + os=-sysv32 + ;; +! i[345]86v4*) + basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + os=-sysv4 + ;; +! i[345]86v) + basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + os=-sysv + ;; +! i[345]86sol2) + basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + os=-solaris2 +--- 309,325 ---- + ;; + # I'm not sure what "Sysv32" means. Should this be sysv3.2? +! i[3456]86v32) + basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + os=-sysv32 + ;; +! i[3456]86v4*) + basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + os=-sysv4 + ;; +! i[3456]86v) + basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + os=-sysv + ;; +! i[3456]86sol2) + basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` + os=-solaris2 +diff -rcp2N gcc-2.7.2.2/configure g77-new/configure +*** gcc-2.7.2.2/configure Thu Feb 20 19:24:33 1997 +--- g77-new/configure Sun Aug 10 18:46:31 1997 +*************** exec_prefix='$(prefix)' +*** 82,85 **** +--- 82,86 ---- + # The default g++ include directory is $(libdir)/g++-include. + gxx_include_dir='$(libdir)/g++-include' ++ #gxx_include_dir='$(exec_prefix)/include/g++' + + # Default --program-transform-name to nothing. +*************** for machine in $canon_build $canon_host +*** 548,551 **** +--- 549,578 ---- + use_collect2=yes + ;; ++ alpha-*-linux*oldas*) ++ tm_file=alpha/linux.h ++ tmake_file=alpha/t-linux ++ xmake_file=alpha/x-linux ++ fixincludes=Makefile.in ++ xm_file=alpha/xm-linux.h ++ gas=yes gnu_ld=yes ++ ;; ++ alpha-*-linux*ecoff*) ++ tm_file=alpha/linux.h ++ tmake_file=alpha/t-linux ++ xmake_file=alpha/x-linux ++ fixincludes=Makefile.in ++ xm_file=alpha/xm-linux.h ++ extra_parts="crtbegin.o crtbeginS.o crtend.o crtendS.o" ++ gas=yes gnu_ld=yes ++ ;; ++ alpha-*-linux*) ++ tm_file=alpha/elf.h ++ tmake_file=alpha/t-linux ++ xmake_file=alpha/x-linux ++ fixincludes=Makefile.in ++ xm_file=alpha/xm-linux.h ++ extra_parts="crtbegin.o crtbeginS.o crtend.o crtendS.o" ++ gas=yes gnu_ld=yes ++ ;; + alpha-dec-osf[23456789]*) + tm_file=alpha/osf2.h +*************** for machine in $canon_build $canon_host +*** 985,989 **** + cpu_type=i386 # with a.out format using pre BFD linkers + xm_file=i386/xm-linux.h +! xmake_file=x-linux + tm_file=i386/linux-oldld.h + fixincludes=Makefile.in # The headers are ok already. +--- 1012,1016 ---- + cpu_type=i386 # with a.out format using pre BFD linkers + xm_file=i386/xm-linux.h +! xmake_file=x-linux-aout + tm_file=i386/linux-oldld.h + fixincludes=Makefile.in # The headers are ok already. +*************** for machine in $canon_build $canon_host +*** 994,998 **** + cpu_type=i386 # with a.out format + xm_file=i386/xm-linux.h +! xmake_file=x-linux + tm_file=i386/linux-aout.h + fixincludes=Makefile.in # The headers are ok already. +--- 1021,1025 ---- + cpu_type=i386 # with a.out format + xm_file=i386/xm-linux.h +! xmake_file=x-linux-aout + tm_file=i386/linux-aout.h + fixincludes=Makefile.in # The headers are ok already. +*************** for machine in $canon_build $canon_host +*** 1003,1007 **** + cpu_type=i386 # with ELF format, using GNU libc v1. + xm_file=i386/xm-linux.h +! xmake_file=x-linux + tmake_file=t-linux-libc1 + tm_file=i386/linux.h +--- 1030,1034 ---- + cpu_type=i386 # with ELF format, using GNU libc v1. + xm_file=i386/xm-linux.h +! xmake_file=x-linux-aout + tmake_file=t-linux-libc1 + tm_file=i386/linux.h +*************** for machine in $canon_build $canon_host +*** 1651,1654 **** +--- 1678,1702 ---- + use_collect2=yes + ;; ++ mips-sni-sysv4) ++ if [ x$gas = xyes ] ++ then ++ if [ x$stabs = xyes ] ++ then ++ tm_file=mips/iris5gdb.h ++ else ++ tm_file=mips/sni-gas.h ++ fi ++ else ++ tm_file=mips/sni-svr4.h ++ fi ++ xm_file=mips/xm-sysv.h ++ xmake_file=mips/x-sni-svr4 ++ tmake_file=mips/t-mips-gas ++ if [ x$gnu_ld != xyes ] ++ then ++ use_collect2=yes ++ fi ++ broken_install=yes ++ ;; + mips-sgi-irix5*) # SGI System V.4., IRIX 5 + if [ x$gas = xyes ] +*************** MAYBE_TARGET_DEFAULT = -DTARGET_CPU_DEFA +*** 2980,2984 **** + rm Makefile.sed + echo 's| ||' > Makefile.sed +! echo "s|^target=.*$|target=${target}|" >> Makefile.sed + echo "s|^xmake_file=.*$|xmake_file=${dep_host_xmake_file}|" >> Makefile.sed + echo "s|^tmake_file=.*$|tmake_file=${dep_tmake_file}|" >> Makefile.sed +--- 3028,3032 ---- + rm Makefile.sed + echo 's| ||' > Makefile.sed +! echo "s|^target=.*$|target=${canon_target}|" >> Makefile.sed + echo "s|^xmake_file=.*$|xmake_file=${dep_host_xmake_file}|" >> Makefile.sed + echo "s|^tmake_file=.*$|tmake_file=${dep_tmake_file}|" >> Makefile.sed +diff -rcp2N gcc-2.7.2.2/cse.c g77-new/cse.c +*** gcc-2.7.2.2/cse.c Sun Nov 26 14:47:05 1995 +--- g77-new/cse.c Sun Aug 10 18:46:37 1997 +*************** static struct table_elt *last_jump_equiv +*** 520,544 **** + static int constant_pool_entries_cost; + +- /* Bits describing what kind of values in memory must be invalidated +- for a particular instruction. If all three bits are zero, +- no memory refs need to be invalidated. Each bit is more powerful +- than the preceding ones, and if a bit is set then the preceding +- bits are also set. +- +- Here is how the bits are set: +- Pushing onto the stack invalidates only the stack pointer, +- writing at a fixed address invalidates only variable addresses, +- writing in a structure element at variable address +- invalidates all but scalar variables, +- and writing in anything else at variable address invalidates everything. */ +- +- struct write_data +- { +- int sp : 1; /* Invalidate stack pointer. */ +- int var : 1; /* Invalidate variable addresses. */ +- int nonscalar : 1; /* Invalidate all but scalar variables. */ +- int all : 1; /* Invalidate all memory refs. */ +- }; +- + /* Define maximum length of a branch path. */ + +--- 520,523 ---- +*************** static void merge_equiv_classes PROTO((s +*** 626,632 **** + struct table_elt *)); + static void invalidate PROTO((rtx, enum machine_mode)); + static void remove_invalid_refs PROTO((int)); + static void rehash_using_reg PROTO((rtx)); +! static void invalidate_memory PROTO((struct write_data *)); + static void invalidate_for_call PROTO((void)); + static rtx use_related_value PROTO((rtx, struct table_elt *)); +--- 605,612 ---- + struct table_elt *)); + static void invalidate PROTO((rtx, enum machine_mode)); ++ static int cse_rtx_varies_p PROTO((rtx)); + static void remove_invalid_refs PROTO((int)); + static void rehash_using_reg PROTO((rtx)); +! static void invalidate_memory PROTO((void)); + static void invalidate_for_call PROTO((void)); + static rtx use_related_value PROTO((rtx, struct table_elt *)); +*************** static void set_nonvarying_address_compo +*** 638,644 **** + HOST_WIDE_INT *)); + static int refers_to_p PROTO((rtx, rtx)); +- static int refers_to_mem_p PROTO((rtx, rtx, HOST_WIDE_INT, +- HOST_WIDE_INT)); +- static int cse_rtx_addr_varies_p PROTO((rtx)); + static rtx canon_reg PROTO((rtx, rtx)); + static void find_best_addr PROTO((rtx, rtx *)); +--- 618,621 ---- +*************** static void record_jump_cond PROTO((enum +*** 656,661 **** + rtx, rtx, int)); + static void cse_insn PROTO((rtx, int)); +! static void note_mem_written PROTO((rtx, struct write_data *)); +! static void invalidate_from_clobbers PROTO((struct write_data *, rtx)); + static rtx cse_process_notes PROTO((rtx, rtx)); + static void cse_around_loop PROTO((rtx)); +--- 633,638 ---- + rtx, rtx, int)); + static void cse_insn PROTO((rtx, int)); +! static int note_mem_written PROTO((rtx)); +! static void invalidate_from_clobbers PROTO((rtx)); + static rtx cse_process_notes PROTO((rtx, rtx)); + static void cse_around_loop PROTO((rtx)); +*************** invalidate (x, full_mode) +*** 1512,1517 **** + register int i; + register struct table_elt *p; +- rtx base; +- HOST_WIDE_INT start, end; + + /* If X is a register, dependencies on its contents +--- 1489,1492 ---- +*************** invalidate (x, full_mode) +*** 1605,1611 **** + full_mode = GET_MODE (x); + +- set_nonvarying_address_components (XEXP (x, 0), GET_MODE_SIZE (full_mode), +- &base, &start, &end); +- + for (i = 0; i < NBUCKETS; i++) + { +--- 1580,1583 ---- +*************** invalidate (x, full_mode) +*** 1614,1618 **** + { + next = p->next_same_hash; +! if (refers_to_mem_p (p->exp, base, start, end)) + remove_from_table (p, i); + } +--- 1586,1594 ---- + { + next = p->next_same_hash; +! /* Invalidate ASM_OPERANDS which reference memory (this is easier +! than checking all the aliases). */ +! if (p->in_memory +! && (GET_CODE (p->exp) != MEM +! || true_dependence (x, full_mode, p->exp, cse_rtx_varies_p))) + remove_from_table (p, i); + } +*************** rehash_using_reg (x) +*** 1695,1722 **** + } + +- /* Remove from the hash table all expressions that reference memory, +- or some of them as specified by *WRITES. */ +- +- static void +- invalidate_memory (writes) +- struct write_data *writes; +- { +- register int i; +- register struct table_elt *p, *next; +- int all = writes->all; +- int nonscalar = writes->nonscalar; +- +- for (i = 0; i < NBUCKETS; i++) +- for (p = table[i]; p; p = next) +- { +- next = p->next_same_hash; +- if (p->in_memory +- && (all +- || (nonscalar && p->in_struct) +- || cse_rtx_addr_varies_p (p->exp))) +- remove_from_table (p, i); +- } +- } +- + /* Remove from the hash table any expression that is a call-clobbered + register. Also update their TICK values. */ +--- 1671,1674 ---- +*************** invalidate_for_call () +*** 1756,1759 **** +--- 1708,1717 ---- + next = p->next_same_hash; + ++ if (p->in_memory) ++ { ++ remove_from_table (p, hash); ++ continue; ++ } ++ + if (GET_CODE (p->exp) != REG + || REGNO (p->exp) >= FIRST_PSEUDO_REGISTER) +*************** canon_hash (x, mode) +*** 1946,1950 **** + return 0; + } +! if (! RTX_UNCHANGING_P (x)) + { + hash_arg_in_memory = 1; +--- 1904,1908 ---- + return 0; + } +! if (! RTX_UNCHANGING_P (x) || FIXED_BASE_PLUS_P (XEXP (x, 0))) + { + hash_arg_in_memory = 1; +*************** set_nonvarying_address_components (addr, +*** 2395,2477 **** + } + +! /* Return 1 iff any subexpression of X refers to memory +! at an address of BASE plus some offset +! such that any of the bytes' offsets fall between START (inclusive) +! and END (exclusive). +! +! The value is undefined if X is a varying address (as determined by +! cse_rtx_addr_varies_p). This function is not used in such cases. +! +! When used in the cse pass, `qty_const' is nonzero, and it is used +! to treat an address that is a register with a known constant value +! as if it were that constant value. +! In the loop pass, `qty_const' is zero, so this is not done. */ +! +! static int +! refers_to_mem_p (x, base, start, end) +! rtx x, base; +! HOST_WIDE_INT start, end; +! { +! register HOST_WIDE_INT i; +! register enum rtx_code code; +! register char *fmt; +! +! repeat: +! if (x == 0) +! return 0; +! +! code = GET_CODE (x); +! if (code == MEM) +! { +! register rtx addr = XEXP (x, 0); /* Get the address. */ +! rtx mybase; +! HOST_WIDE_INT mystart, myend; +! +! set_nonvarying_address_components (addr, GET_MODE_SIZE (GET_MODE (x)), +! &mybase, &mystart, &myend); +! +! +! /* refers_to_mem_p is never called with varying addresses. +! If the base addresses are not equal, there is no chance +! of the memory addresses conflicting. */ +! if (! rtx_equal_p (mybase, base)) +! return 0; +! +! return myend > start && mystart < end; +! } +! +! /* X does not match, so try its subexpressions. */ +! +! fmt = GET_RTX_FORMAT (code); +! for (i = GET_RTX_LENGTH (code) - 1; i >= 0; i--) +! if (fmt[i] == 'e') +! { +! if (i == 0) +! { +! x = XEXP (x, 0); +! goto repeat; +! } +! else +! if (refers_to_mem_p (XEXP (x, i), base, start, end)) +! return 1; +! } +! else if (fmt[i] == 'E') +! { +! int j; +! for (j = 0; j < XVECLEN (x, i); j++) +! if (refers_to_mem_p (XVECEXP (x, i, j), base, start, end)) +! return 1; +! } +! +! return 0; +! } +! +! /* Nonzero if X refers to memory at a varying address; + except that a register which has at the moment a known constant value + isn't considered variable. */ + + static int +! cse_rtx_addr_varies_p (x) +! rtx x; + { + /* We need not check for X and the equivalence class being of the same +--- 2353,2363 ---- + } + +! /* Nonzero if X, a memory address, refers to a varying address; + except that a register which has at the moment a known constant value + isn't considered variable. */ + + static int +! cse_rtx_varies_p (x) +! register rtx x; + { + /* We need not check for X and the equivalence class being of the same +*************** cse_rtx_addr_varies_p (x) +*** 2479,2497 **** + doesn't vary in any mode. */ + +! if (GET_CODE (x) == MEM +! && GET_CODE (XEXP (x, 0)) == REG +! && REGNO_QTY_VALID_P (REGNO (XEXP (x, 0))) +! && GET_MODE (XEXP (x, 0)) == qty_mode[reg_qty[REGNO (XEXP (x, 0))]] +! && qty_const[reg_qty[REGNO (XEXP (x, 0))]] != 0) + return 0; + +! if (GET_CODE (x) == MEM +! && GET_CODE (XEXP (x, 0)) == PLUS +! && GET_CODE (XEXP (XEXP (x, 0), 1)) == CONST_INT +! && GET_CODE (XEXP (XEXP (x, 0), 0)) == REG +! && REGNO_QTY_VALID_P (REGNO (XEXP (XEXP (x, 0), 0))) +! && (GET_MODE (XEXP (XEXP (x, 0), 0)) +! == qty_mode[reg_qty[REGNO (XEXP (XEXP (x, 0), 0))]]) +! && qty_const[reg_qty[REGNO (XEXP (XEXP (x, 0), 0))]]) + return 0; + +--- 2365,2381 ---- + doesn't vary in any mode. */ + +! if (GET_CODE (x) == REG +! && REGNO_QTY_VALID_P (REGNO (x)) +! && GET_MODE (x) == qty_mode[reg_qty[REGNO (x)]] +! && qty_const[reg_qty[REGNO (x)]] != 0) + return 0; + +! if (GET_CODE (x) == PLUS +! && GET_CODE (XEXP (x, 1)) == CONST_INT +! && GET_CODE (XEXP (x, 0)) == REG +! && REGNO_QTY_VALID_P (REGNO (XEXP (x, 0))) +! && (GET_MODE (XEXP (x, 0)) +! == qty_mode[reg_qty[REGNO (XEXP (x, 0))]]) +! && qty_const[reg_qty[REGNO (XEXP (x, 0))]]) + return 0; + +*************** cse_rtx_addr_varies_p (x) +*** 2501,2519 **** + load fp minus a constant into a register, then a MEM which is the + sum of the two `constant' registers. */ +! if (GET_CODE (x) == MEM +! && GET_CODE (XEXP (x, 0)) == PLUS +! && GET_CODE (XEXP (XEXP (x, 0), 0)) == REG +! && GET_CODE (XEXP (XEXP (x, 0), 1)) == REG +! && REGNO_QTY_VALID_P (REGNO (XEXP (XEXP (x, 0), 0))) +! && (GET_MODE (XEXP (XEXP (x, 0), 0)) +! == qty_mode[reg_qty[REGNO (XEXP (XEXP (x, 0), 0))]]) +! && qty_const[reg_qty[REGNO (XEXP (XEXP (x, 0), 0))]] +! && REGNO_QTY_VALID_P (REGNO (XEXP (XEXP (x, 0), 1))) +! && (GET_MODE (XEXP (XEXP (x, 0), 1)) +! == qty_mode[reg_qty[REGNO (XEXP (XEXP (x, 0), 1))]]) +! && qty_const[reg_qty[REGNO (XEXP (XEXP (x, 0), 1))]]) + return 0; + +! return rtx_addr_varies_p (x); + } + +--- 2385,2402 ---- + load fp minus a constant into a register, then a MEM which is the + sum of the two `constant' registers. */ +! if (GET_CODE (x) == PLUS +! && GET_CODE (XEXP (x, 0)) == REG +! && GET_CODE (XEXP (x, 1)) == REG +! && REGNO_QTY_VALID_P (REGNO (XEXP (x, 0))) +! && (GET_MODE (XEXP (x, 0)) +! == qty_mode[reg_qty[REGNO (XEXP (x, 0))]]) +! && qty_const[reg_qty[REGNO (XEXP (x, 0))]] +! && REGNO_QTY_VALID_P (REGNO (XEXP (x, 1))) +! && (GET_MODE (XEXP (x, 1)) +! == qty_mode[reg_qty[REGNO (XEXP (x, 1))]]) +! && qty_const[reg_qty[REGNO (XEXP (x, 1))]]) + return 0; + +! return rtx_varies_p (x); + } + +*************** cse_insn (insn, in_libcall_block) +*** 6105,6110 **** + rtx this_insn_cc0 = 0; + enum machine_mode this_insn_cc0_mode; +- struct write_data writes_memory; +- static struct write_data init = {0, 0, 0, 0}; + + rtx src_eqv = 0; +--- 5988,5991 ---- +*************** cse_insn (insn, in_libcall_block) +*** 6118,6122 **** + + this_insn = insn; +- writes_memory = init; + + /* Find all the SETs and CLOBBERs in this instruction. +--- 5999,6002 ---- +*************** cse_insn (insn, in_libcall_block) +*** 6220,6232 **** + else if (GET_CODE (y) == CLOBBER) + { +! /* If we clobber memory, take note of that, +! and canon the address. + This does nothing when a register is clobbered + because we have already invalidated the reg. */ + if (GET_CODE (XEXP (y, 0)) == MEM) +! { +! canon_reg (XEXP (y, 0), NULL_RTX); +! note_mem_written (XEXP (y, 0), &writes_memory); +! } + } + else if (GET_CODE (y) == USE +--- 6100,6108 ---- + else if (GET_CODE (y) == CLOBBER) + { +! /* If we clobber memory, canon the address. + This does nothing when a register is clobbered + because we have already invalidated the reg. */ + if (GET_CODE (XEXP (y, 0)) == MEM) +! canon_reg (XEXP (y, 0), NULL_RTX); + } + else if (GET_CODE (y) == USE +*************** cse_insn (insn, in_libcall_block) +*** 6247,6254 **** + { + if (GET_CODE (XEXP (x, 0)) == MEM) +! { +! canon_reg (XEXP (x, 0), NULL_RTX); +! note_mem_written (XEXP (x, 0), &writes_memory); +! } + } + +--- 6123,6127 ---- + { + if (GET_CODE (XEXP (x, 0)) == MEM) +! canon_reg (XEXP (x, 0), NULL_RTX); + } + +*************** cse_insn (insn, in_libcall_block) +*** 6674,6678 **** + } + #endif /* LOAD_EXTEND_OP */ +! + if (src == src_folded) + src_folded = 0; +--- 6547,6551 ---- + } + #endif /* LOAD_EXTEND_OP */ +! + if (src == src_folded) + src_folded = 0; +*************** cse_insn (insn, in_libcall_block) +*** 6860,6864 **** + || (GET_CODE (src_folded) != MEM + && ! src_folded_force_flag)) +! && GET_MODE_CLASS (mode) != MODE_CC) + { + src_folded_force_flag = 1; +--- 6733,6738 ---- + || (GET_CODE (src_folded) != MEM + && ! src_folded_force_flag)) +! && GET_MODE_CLASS (mode) != MODE_CC +! && mode != VOIDmode) + { + src_folded_force_flag = 1; +*************** cse_insn (insn, in_libcall_block) +*** 6983,6993 **** + if (GET_CODE (dest) == MEM) + { + dest = fold_rtx (dest, insn); +- +- /* Decide whether we invalidate everything in memory, +- or just things at non-fixed places. +- Writing a large aggregate must invalidate everything +- because we don't know how long it is. */ +- note_mem_written (dest, &writes_memory); + } + +--- 6857,6869 ---- + if (GET_CODE (dest) == MEM) + { ++ #ifdef PUSH_ROUNDING ++ /* Stack pushes invalidate the stack pointer. */ ++ rtx addr = XEXP (dest, 0); ++ if ((GET_CODE (addr) == PRE_DEC || GET_CODE (addr) == PRE_INC ++ || GET_CODE (addr) == POST_DEC || GET_CODE (addr) == POST_INC) ++ && XEXP (addr, 0) == stack_pointer_rtx) ++ invalidate (stack_pointer_rtx, Pmode); ++ #endif + dest = fold_rtx (dest, insn); + } + +*************** cse_insn (insn, in_libcall_block) +*** 7234,7238 **** + sets[i].src_elt = src_eqv_elt; + +! invalidate_from_clobbers (&writes_memory, x); + + /* Some registers are invalidated by subroutine calls. Memory is +--- 7110,7114 ---- + sets[i].src_elt = src_eqv_elt; + +! invalidate_from_clobbers (x); + + /* Some registers are invalidated by subroutine calls. Memory is +*************** cse_insn (insn, in_libcall_block) +*** 7241,7248 **** + if (GET_CODE (insn) == CALL_INSN) + { +- static struct write_data everything = {0, 1, 1, 1}; +- + if (! CONST_CALL_P (insn)) +! invalidate_memory (&everything); + invalidate_for_call (); + } +--- 7117,7122 ---- + if (GET_CODE (insn) == CALL_INSN) + { + if (! CONST_CALL_P (insn)) +! invalidate_memory (); + invalidate_for_call (); + } +*************** cse_insn (insn, in_libcall_block) +*** 7265,7270 **** + we have just done an invalidate_memory that covers even those. */ + if (GET_CODE (dest) == REG || GET_CODE (dest) == SUBREG +! || (GET_CODE (dest) == MEM && ! writes_memory.all +! && ! cse_rtx_addr_varies_p (dest))) + invalidate (dest, VOIDmode); + else if (GET_CODE (dest) == STRICT_LOW_PART +--- 7139,7143 ---- + we have just done an invalidate_memory that covers even those. */ + if (GET_CODE (dest) == REG || GET_CODE (dest) == SUBREG +! || GET_CODE (dest) == MEM) + invalidate (dest, VOIDmode); + else if (GET_CODE (dest) == STRICT_LOW_PART +*************** cse_insn (insn, in_libcall_block) +*** 7359,7363 **** + sets[i].dest_hash, GET_MODE (dest)); + elt->in_memory = (GET_CODE (sets[i].inner_dest) == MEM +! && ! RTX_UNCHANGING_P (sets[i].inner_dest)); + + if (elt->in_memory) +--- 7232,7238 ---- + sets[i].dest_hash, GET_MODE (dest)); + elt->in_memory = (GET_CODE (sets[i].inner_dest) == MEM +! && (! RTX_UNCHANGING_P (sets[i].inner_dest) +! || FIXED_BASE_PLUS_P (XEXP (sets[i].inner_dest, +! 0)))); + + if (elt->in_memory) +*************** cse_insn (insn, in_libcall_block) +*** 7532,7580 **** + } + +- /* Store 1 in *WRITES_PTR for those categories of memory ref +- that must be invalidated when the expression WRITTEN is stored in. +- If WRITTEN is null, say everything must be invalidated. */ +- + static void +! note_mem_written (written, writes_ptr) +! rtx written; +! struct write_data *writes_ptr; +! { +! static struct write_data everything = {0, 1, 1, 1}; +! +! if (written == 0) +! *writes_ptr = everything; +! else if (GET_CODE (written) == MEM) +! { +! /* Pushing or popping the stack invalidates just the stack pointer. */ +! rtx addr = XEXP (written, 0); +! if ((GET_CODE (addr) == PRE_DEC || GET_CODE (addr) == PRE_INC +! || GET_CODE (addr) == POST_DEC || GET_CODE (addr) == POST_INC) +! && GET_CODE (XEXP (addr, 0)) == REG +! && REGNO (XEXP (addr, 0)) == STACK_POINTER_REGNUM) +! { +! writes_ptr->sp = 1; +! return; +! } +! else if (GET_MODE (written) == BLKmode) +! *writes_ptr = everything; +! /* (mem (scratch)) means clobber everything. */ +! else if (GET_CODE (addr) == SCRATCH) +! *writes_ptr = everything; +! else if (cse_rtx_addr_varies_p (written)) +! { +! /* A varying address that is a sum indicates an array element, +! and that's just as good as a structure element +! in implying that we need not invalidate scalar variables. +! However, we must allow QImode aliasing of scalars, because the +! ANSI C standard allows character pointers to alias anything. */ +! if (! ((MEM_IN_STRUCT_P (written) +! || GET_CODE (XEXP (written, 0)) == PLUS) +! && GET_MODE (written) != QImode)) +! writes_ptr->all = 1; +! writes_ptr->nonscalar = 1; +! } +! writes_ptr->var = 1; + } + } + +--- 7407,7450 ---- + } + + static void +! invalidate_memory () +! { +! register int i; +! register struct table_elt *p, *next; +! +! for (i = 0; i < NBUCKETS; i++) +! for (p = table[i]; p; p = next) +! { +! next = p->next_same_hash; +! if (p->in_memory) +! remove_from_table (p, i); +! } +! } +! +! static int +! note_mem_written (mem) +! register rtx mem; +! { +! if (mem == 0 || GET_CODE(mem) != MEM ) +! return 0; +! else +! { +! register rtx addr = XEXP (mem, 0); +! /* Pushing or popping the stack invalidates just the stack pointer. */ +! if ((GET_CODE (addr) == PRE_DEC || GET_CODE (addr) == PRE_INC +! || GET_CODE (addr) == POST_DEC || GET_CODE (addr) == POST_INC) +! && GET_CODE (XEXP (addr, 0)) == REG +! && REGNO (XEXP (addr, 0)) == STACK_POINTER_REGNUM) +! { +! if (reg_tick[STACK_POINTER_REGNUM] >= 0) +! reg_tick[STACK_POINTER_REGNUM]++; +! +! /* This should be *very* rare. */ +! if (TEST_HARD_REG_BIT (hard_regs_in_table, STACK_POINTER_REGNUM)) +! invalidate (stack_pointer_rtx, VOIDmode); +! return 1; + } ++ return 0; ++ } + } + +*************** note_mem_written (written, writes_ptr) +*** 7584,7612 **** + alias with something that is SET or CLOBBERed. + +- W points to the writes_memory for this insn, a struct write_data +- saying which kinds of memory references must be invalidated. + X is the pattern of the insn. */ + + static void +! invalidate_from_clobbers (w, x) +! struct write_data *w; + rtx x; + { +- /* If W->var is not set, W specifies no action. +- If W->all is set, this step gets all memory refs +- so they can be ignored in the rest of this function. */ +- if (w->var) +- invalidate_memory (w); +- +- if (w->sp) +- { +- if (reg_tick[STACK_POINTER_REGNUM] >= 0) +- reg_tick[STACK_POINTER_REGNUM]++; +- +- /* This should be *very* rare. */ +- if (TEST_HARD_REG_BIT (hard_regs_in_table, STACK_POINTER_REGNUM)) +- invalidate (stack_pointer_rtx, VOIDmode); +- } +- + if (GET_CODE (x) == CLOBBER) + { +--- 7454,7463 ---- + alias with something that is SET or CLOBBERed. + + X is the pattern of the insn. */ + + static void +! invalidate_from_clobbers (x) + rtx x; + { + if (GET_CODE (x) == CLOBBER) + { +*************** invalidate_from_clobbers (w, x) +*** 7615,7619 **** + { + if (GET_CODE (ref) == REG || GET_CODE (ref) == SUBREG +! || (GET_CODE (ref) == MEM && ! w->all)) + invalidate (ref, VOIDmode); + else if (GET_CODE (ref) == STRICT_LOW_PART +--- 7466,7470 ---- + { + if (GET_CODE (ref) == REG || GET_CODE (ref) == SUBREG +! || GET_CODE (ref) == MEM) + invalidate (ref, VOIDmode); + else if (GET_CODE (ref) == STRICT_LOW_PART +*************** invalidate_from_clobbers (w, x) +*** 7631,7643 **** + { + rtx ref = XEXP (y, 0); +! if (ref) +! { +! if (GET_CODE (ref) == REG || GET_CODE (ref) == SUBREG +! || (GET_CODE (ref) == MEM && !w->all)) +! invalidate (ref, VOIDmode); +! else if (GET_CODE (ref) == STRICT_LOW_PART +! || GET_CODE (ref) == ZERO_EXTRACT) +! invalidate (XEXP (ref, 0), GET_MODE (ref)); +! } + } + } +--- 7482,7491 ---- + { + rtx ref = XEXP (y, 0); +! if (GET_CODE (ref) == REG || GET_CODE (ref) == SUBREG +! || GET_CODE (ref) == MEM) +! invalidate (ref, VOIDmode); +! else if (GET_CODE (ref) == STRICT_LOW_PART +! || GET_CODE (ref) == ZERO_EXTRACT) +! invalidate (XEXP (ref, 0), GET_MODE (ref)); + } + } +*************** cse_around_loop (loop_start) +*** 7800,7807 **** + } + +- /* Variable used for communications between the next two routines. */ +- +- static struct write_data skipped_writes_memory; +- + /* Process one SET of an insn that was skipped. We ignore CLOBBERs + since they are done elsewhere. This function is called via note_stores. */ +--- 7648,7651 ---- +*************** invalidate_skipped_set (dest, set) +*** 7812,7815 **** +--- 7656,7675 ---- + rtx dest; + { ++ enum rtx_code code = GET_CODE (dest); ++ ++ if (code == MEM ++ && ! note_mem_written (dest) /* If this is not a stack push ... */ ++ /* There are times when an address can appear varying and be a PLUS ++ during this scan when it would be a fixed address were we to know ++ the proper equivalences. So invalidate all memory if there is ++ a BLKmode or nonscalar memory reference or a reference to a ++ variable address. */ ++ && (MEM_IN_STRUCT_P (dest) || GET_MODE (dest) == BLKmode ++ || cse_rtx_varies_p (XEXP (dest, 0)))) ++ { ++ invalidate_memory (); ++ return; ++ } ++ + if (GET_CODE (set) == CLOBBER + #ifdef HAVE_cc0 +*************** invalidate_skipped_set (dest, set) +*** 7819,7837 **** + return; + +! if (GET_CODE (dest) == MEM) +! note_mem_written (dest, &skipped_writes_memory); +! +! /* There are times when an address can appear varying and be a PLUS +! during this scan when it would be a fixed address were we to know +! the proper equivalences. So promote "nonscalar" to be "all". */ +! if (skipped_writes_memory.nonscalar) +! skipped_writes_memory.all = 1; +! +! if (GET_CODE (dest) == REG || GET_CODE (dest) == SUBREG +! || (! skipped_writes_memory.all && ! cse_rtx_addr_varies_p (dest))) +! invalidate (dest, VOIDmode); +! else if (GET_CODE (dest) == STRICT_LOW_PART +! || GET_CODE (dest) == ZERO_EXTRACT) + invalidate (XEXP (dest, 0), GET_MODE (dest)); + } + +--- 7679,7686 ---- + return; + +! if (code == STRICT_LOW_PART || code == ZERO_EXTRACT) + invalidate (XEXP (dest, 0), GET_MODE (dest)); ++ else if (code == REG || code == SUBREG || code == MEM) ++ invalidate (dest, VOIDmode); + } + +*************** invalidate_skipped_block (start) +*** 7845,7850 **** + { + rtx insn; +- static struct write_data init = {0, 0, 0, 0}; +- static struct write_data everything = {0, 1, 1, 1}; + + for (insn = start; insn && GET_CODE (insn) != CODE_LABEL; +--- 7694,7697 ---- +*************** invalidate_skipped_block (start) +*** 7854,7867 **** + continue; + +- skipped_writes_memory = init; +- + if (GET_CODE (insn) == CALL_INSN) + { + invalidate_for_call (); +- skipped_writes_memory = everything; + } + + note_stores (PATTERN (insn), invalidate_skipped_set); +- invalidate_from_clobbers (&skipped_writes_memory, PATTERN (insn)); + } + } +--- 7701,7712 ---- + continue; + + if (GET_CODE (insn) == CALL_INSN) + { ++ if (! CONST_CALL_P (insn)) ++ invalidate_memory (); + invalidate_for_call (); + } + + note_stores (PATTERN (insn), invalidate_skipped_set); + } + } +*************** cse_set_around_loop (x, insn, loop_start +*** 7913,7920 **** + { + struct table_elt *src_elt; +- static struct write_data init = {0, 0, 0, 0}; +- struct write_data writes_memory; +- +- writes_memory = init; + + /* If this is a SET, see if we can replace SET_SRC, but ignore SETs that +--- 7758,7761 ---- +*************** cse_set_around_loop (x, insn, loop_start +*** 7976,7991 **** + + /* Now invalidate anything modified by X. */ +! note_mem_written (SET_DEST (x), &writes_memory); +! +! if (writes_memory.var) +! invalidate_memory (&writes_memory); +! +! /* See comment on similar code in cse_insn for explanation of these tests. */ + if (GET_CODE (SET_DEST (x)) == REG || GET_CODE (SET_DEST (x)) == SUBREG +! || (GET_CODE (SET_DEST (x)) == MEM && ! writes_memory.all +! && ! cse_rtx_addr_varies_p (SET_DEST (x)))) + invalidate (SET_DEST (x), VOIDmode); + else if (GET_CODE (SET_DEST (x)) == STRICT_LOW_PART +! || GET_CODE (SET_DEST (x)) == ZERO_EXTRACT) + invalidate (XEXP (SET_DEST (x), 0), GET_MODE (SET_DEST (x))); + } +--- 7817,7828 ---- + + /* Now invalidate anything modified by X. */ +! note_mem_written (SET_DEST (x)); +! +! /* See comment on similar code in cse_insn for explanation of these tests. */ + if (GET_CODE (SET_DEST (x)) == REG || GET_CODE (SET_DEST (x)) == SUBREG +! || GET_CODE (SET_DEST (x)) == MEM) + invalidate (SET_DEST (x), VOIDmode); + else if (GET_CODE (SET_DEST (x)) == STRICT_LOW_PART +! || GET_CODE (SET_DEST (x)) == ZERO_EXTRACT) + invalidate (XEXP (SET_DEST (x), 0), GET_MODE (SET_DEST (x))); + } +*************** cse_main (f, nregs, after_loop, file) +*** 8234,8237 **** +--- 8071,8075 ---- + + init_recog (); ++ init_alias_analysis (); + + max_reg = nregs; +*************** cse_basic_block (from, to, next_branch, +*** 8405,8408 **** +--- 8243,8247 ---- + int to_usage = 0; + int in_libcall_block = 0; ++ int num_insns = 0; + + /* Each of these arrays is undefined before max_reg, so only allocate +*************** cse_basic_block (from, to, next_branch, +*** 8437,8440 **** +--- 8276,8299 ---- + { + register enum rtx_code code; ++ int i; ++ struct table_elt *p, *next; ++ ++ /* If we have processed 1,000 insns, flush the hash table to avoid ++ extreme quadratic behavior. */ ++ if (num_insns++ > 1000) ++ { ++ for (i = 0; i < NBUCKETS; i++) ++ for (p = table[i]; p; p = next) ++ { ++ next = p->next_same_hash; ++ ++ if (GET_CODE (p->exp) == REG) ++ invalidate (p->exp, p->mode); ++ else ++ remove_from_table (p, i); ++ } ++ ++ num_insns = 0; ++ } + + /* See if this is a branch that is part of the path. If so, and it is +diff -rcp2N gcc-2.7.2.2/dwarfout.c g77-new/dwarfout.c +*** gcc-2.7.2.2/dwarfout.c Thu Oct 26 21:40:07 1995 +--- g77-new/dwarfout.c Sun Aug 10 18:47:19 1997 +*************** output_bound_representation (bound, dim_ +*** 1629,1705 **** + { + +! case ERROR_MARK: +! return; + + /* All fixed-bounds are represented by INTEGER_CST nodes. */ + +! case INTEGER_CST: +! ASM_OUTPUT_DWARF_DATA4 (asm_out_file, +! (unsigned) TREE_INT_CST_LOW (bound)); +! break; +! +! /* Dynamic bounds may be represented by NOP_EXPR nodes containing +! SAVE_EXPR nodes. */ +! +! case NOP_EXPR: +! bound = TREE_OPERAND (bound, 0); +! /* ... fall thru... */ +! +! case SAVE_EXPR: +! { +! char begin_label[MAX_ARTIFICIAL_LABEL_BYTES]; +! char end_label[MAX_ARTIFICIAL_LABEL_BYTES]; +! +! sprintf (begin_label, BOUND_BEGIN_LABEL_FMT, +! current_dienum, dim_num, u_or_l); + +! sprintf (end_label, BOUND_END_LABEL_FMT, +! current_dienum, dim_num, u_or_l); + +! ASM_OUTPUT_DWARF_DELTA2 (asm_out_file, end_label, begin_label); +! ASM_OUTPUT_LABEL (asm_out_file, begin_label); + +! /* If we are working on a bound for a dynamic dimension in C, +! the dynamic dimension in question had better have a static +! (zero) lower bound and a dynamic *upper* bound. */ + +! if (u_or_l != 'u') +! abort (); + +! /* If optimization is turned on, the SAVE_EXPRs that describe +! how to access the upper bound values are essentially bogus. +! They only describe (at best) how to get at these values at +! the points in the generated code right after they have just +! been computed. Worse yet, in the typical case, the upper +! bound values will not even *be* computed in the optimized +! code, so these SAVE_EXPRs are entirely bogus. +! +! In order to compensate for this fact, we check here to see +! if optimization is enabled, and if so, we effectively create +! an empty location description for the (unknown and unknowable) +! upper bound. +! +! This should not cause too much trouble for existing (stupid?) +! debuggers because they have to deal with empty upper bounds +! location descriptions anyway in order to be able to deal with +! incomplete array types. +! +! Of course an intelligent debugger (GDB?) should be able to +! comprehend that a missing upper bound specification in a +! array type used for a storage class `auto' local array variable +! indicates that the upper bound is both unknown (at compile- +! time) and unknowable (at run-time) due to optimization. +! */ +! +! if (! optimize) +! output_loc_descriptor +! (eliminate_regs (SAVE_EXPR_RTL (bound), 0, NULL_RTX)); + +! ASM_OUTPUT_LABEL (asm_out_file, end_label); +! } +! break; + +- default: +- abort (); + } + } +--- 1629,1699 ---- + { + +! case ERROR_MARK: +! return; + + /* All fixed-bounds are represented by INTEGER_CST nodes. */ + +! case INTEGER_CST: +! ASM_OUTPUT_DWARF_DATA4 (asm_out_file, +! (unsigned) TREE_INT_CST_LOW (bound)); +! break; + +! default: + +! /* Dynamic bounds may be represented by NOP_EXPR nodes containing +! SAVE_EXPR nodes, in which case we can do something, or as +! an expression, which we cannot represent. */ +! { +! char begin_label[MAX_ARTIFICIAL_LABEL_BYTES]; +! char end_label[MAX_ARTIFICIAL_LABEL_BYTES]; + +! sprintf (begin_label, BOUND_BEGIN_LABEL_FMT, +! current_dienum, dim_num, u_or_l); + +! sprintf (end_label, BOUND_END_LABEL_FMT, +! current_dienum, dim_num, u_or_l); + +! ASM_OUTPUT_DWARF_DELTA2 (asm_out_file, end_label, begin_label); +! ASM_OUTPUT_LABEL (asm_out_file, begin_label); +! +! /* If optimization is turned on, the SAVE_EXPRs that describe +! how to access the upper bound values are essentially bogus. +! They only describe (at best) how to get at these values at +! the points in the generated code right after they have just +! been computed. Worse yet, in the typical case, the upper +! bound values will not even *be* computed in the optimized +! code, so these SAVE_EXPRs are entirely bogus. +! +! In order to compensate for this fact, we check here to see +! if optimization is enabled, and if so, we effectively create +! an empty location description for the (unknown and unknowable) +! upper bound. +! +! This should not cause too much trouble for existing (stupid?) +! debuggers because they have to deal with empty upper bounds +! location descriptions anyway in order to be able to deal with +! incomplete array types. +! +! Of course an intelligent debugger (GDB?) should be able to +! comprehend that a missing upper bound specification in a +! array type used for a storage class `auto' local array variable +! indicates that the upper bound is both unknown (at compile- +! time) and unknowable (at run-time) due to optimization. */ +! +! if (! optimize) +! { +! while (TREE_CODE (bound) == NOP_EXPR +! || TREE_CODE (bound) == CONVERT_EXPR) +! bound = TREE_OPERAND (bound, 0); +! +! if (TREE_CODE (bound) == SAVE_EXPR) +! output_loc_descriptor +! (eliminate_regs (SAVE_EXPR_RTL (bound), 0, NULL_RTX)); +! } + +! ASM_OUTPUT_LABEL (asm_out_file, end_label); +! } +! break; + + } + } +*************** type_attribute (type, decl_const, decl_v +*** 2857,2861 **** + register int root_type_modified; + +! if (TREE_CODE (type) == ERROR_MARK) + return; + +--- 2851,2855 ---- + register int root_type_modified; + +! if (code == ERROR_MARK) + return; + +*************** type_attribute (type, decl_const, decl_v +*** 2864,2869 **** + type `void', so this only applies to function return types. */ + +! if (TREE_CODE (type) == VOID_TYPE) + return; + + root_type_modified = (code == POINTER_TYPE || code == REFERENCE_TYPE +--- 2858,2869 ---- + type `void', so this only applies to function return types. */ + +! if (code == VOID_TYPE) + return; ++ ++ /* If this is a subtype, find the underlying type. Eventually, ++ this should write out the appropriate subtype info. */ ++ while ((code == INTEGER_TYPE || code == REAL_TYPE) ++ && TREE_TYPE (type) != 0) ++ type = TREE_TYPE (type), code = TREE_CODE (type); + + root_type_modified = (code == POINTER_TYPE || code == REFERENCE_TYPE +diff -rcp2N gcc-2.7.2.2/emit-rtl.c g77-new/emit-rtl.c +*** gcc-2.7.2.2/emit-rtl.c Thu Sep 14 16:09:30 1995 +--- g77-new/emit-rtl.c Sun Aug 10 18:47:08 1997 +*************** max_label_num () +*** 545,548 **** +--- 545,565 ---- + } + ++ /* Identify REG (which may be a CONCAT) as a user register. */ ++ ++ void ++ mark_user_reg (reg) ++ rtx reg; ++ { ++ if (GET_CODE (reg) == CONCAT) ++ { ++ REG_USERVAR_P (XEXP (reg, 0)) = 1; ++ REG_USERVAR_P (XEXP (reg, 1)) = 1; ++ } ++ else if (GET_CODE (reg) == REG) ++ REG_USERVAR_P (reg) = 1; ++ else ++ abort (); ++ } ++ + /* Return first label number used in this function (if any were used). */ + +*************** change_address (memref, mode, addr) +*** 1315,1318 **** +--- 1332,1338 ---- + addr = memory_address (mode, addr); + ++ if (rtx_equal_p (addr, XEXP (memref, 0)) && mode == GET_MODE (memref)) ++ return memref; ++ + new = gen_rtx (MEM, mode, addr); + MEM_VOLATILE_P (new) = MEM_VOLATILE_P (memref); +diff -rcp2N gcc-2.7.2.2/explow.c g77-new/explow.c +*** gcc-2.7.2.2/explow.c Thu Jun 15 07:30:10 1995 +--- g77-new/explow.c Sun Aug 10 18:46:30 1997 +*************** convert_memory_address (to_mode, x) +*** 305,310 **** +--- 305,313 ---- + rtx x; + { ++ enum machine_mode from_mode = to_mode == ptr_mode ? Pmode : ptr_mode; + rtx temp; + ++ /* Here we handle some special cases. If none of them apply, fall through ++ to the default case. */ + switch (GET_CODE (x)) + { +*************** convert_memory_address (to_mode, x) +*** 321,339 **** + return temp; + +- case PLUS: +- case MULT: +- return gen_rtx (GET_CODE (x), to_mode, +- convert_memory_address (to_mode, XEXP (x, 0)), +- convert_memory_address (to_mode, XEXP (x, 1))); +- + case CONST: + return gen_rtx (CONST, to_mode, + convert_memory_address (to_mode, XEXP (x, 0))); + +! default: +! return convert_modes (to_mode, +! to_mode == ptr_mode ? Pmode : ptr_mode, +! x, POINTERS_EXTEND_UNSIGNED); + } + } + #endif +--- 324,348 ---- + return temp; + + case CONST: + return gen_rtx (CONST, to_mode, + convert_memory_address (to_mode, XEXP (x, 0))); + +! case PLUS: +! case MULT: +! /* For addition the second operand is a small constant, we can safely +! permute the converstion and addition operation. We can always safely +! permute them if we are making the address narrower. In addition, +! always permute the operations if this is a constant. */ +! if (GET_MODE_SIZE (to_mode) < GET_MODE_SIZE (from_mode) +! || (GET_CODE (x) == PLUS && GET_CODE (XEXP (x, 1)) == CONST_INT +! && (INTVAL (XEXP (x, 1)) + 20000 < 40000 +! || CONSTANT_P (XEXP (x, 0))))) +! return gen_rtx (GET_CODE (x), to_mode, +! convert_memory_address (to_mode, XEXP (x, 0)), +! convert_memory_address (to_mode, XEXP (x, 1))); + } ++ ++ return convert_modes (to_mode, from_mode, ++ x, POINTERS_EXTEND_UNSIGNED); + } + #endif +diff -rcp2N gcc-2.7.2.2/expmed.c g77-new/expmed.c +*** gcc-2.7.2.2/expmed.c Thu Jul 13 19:25:37 1995 +--- g77-new/expmed.c Sun Aug 10 18:46:23 1997 +*************** store_bit_field (str_rtx, bitsize, bitnu +*** 399,402 **** +--- 399,403 ---- + #ifdef HAVE_insv + if (HAVE_insv ++ && GET_MODE (value) != BLKmode + && !(bitsize == 1 && GET_CODE (value) == CONST_INT) + /* Ensure insv's size is wide enough for this field. */ +*************** store_split_bit_field (op0, bitsize, bit +*** 777,781 **** + done in extract_bit_field, so that the two calls to + extract_fixed_bit_field will have comparable arguments. */ +! if (GET_CODE (value) != MEM) + total_bits = BITS_PER_WORD; + else +--- 778,782 ---- + done in extract_bit_field, so that the two calls to + extract_fixed_bit_field will have comparable arguments. */ +! if (GET_CODE (value) != MEM || GET_MODE (value) == BLKmode) + total_bits = BITS_PER_WORD; + else +*************** store_split_bit_field (op0, bitsize, bit +*** 790,797 **** + /* The args are chosen so that the last part includes the + lsb. Give extract_bit_field the value it needs (with +! endianness compensation) to fetch the piece we want. */ +! part = extract_fixed_bit_field (word_mode, value, 0, thissize, +! total_bits - bitsize + bitsdone, +! NULL_RTX, 1, align); + } + else +--- 791,807 ---- + /* The args are chosen so that the last part includes the + lsb. Give extract_bit_field the value it needs (with +! endianness compensation) to fetch the piece we want. +! +! ??? We have no idea what the alignment of VALUE is, so +! we have to use a guess. */ +! part +! = extract_fixed_bit_field +! (word_mode, value, 0, thissize, +! total_bits - bitsize + bitsdone, NULL_RTX, 1, +! GET_MODE (value) == VOIDmode +! ? UNITS_PER_WORD +! : (GET_MODE (value) == BLKmode +! ? 1 +! : GET_MODE_ALIGNMENT (GET_MODE (value)) / BITS_PER_UNIT)); + } + else +*************** store_split_bit_field (op0, bitsize, bit +*** 803,808 **** + & (((HOST_WIDE_INT) 1 << thissize) - 1)); + else +! part = extract_fixed_bit_field (word_mode, value, 0, thissize, +! bitsdone, NULL_RTX, 1, align); + } + +--- 813,824 ---- + & (((HOST_WIDE_INT) 1 << thissize) - 1)); + else +! part +! = extract_fixed_bit_field +! (word_mode, value, 0, thissize, bitsdone, NULL_RTX, 1, +! GET_MODE (value) == VOIDmode +! ? UNITS_PER_WORD +! : (GET_MODE (value) == BLKmode +! ? 1 +! : GET_MODE_ALIGNMENT (GET_MODE (value)) / BITS_PER_UNIT)); + } + +*************** extract_bit_field (str_rtx, bitsize, bit +*** 876,882 **** + rtx spec_target_subreg = 0; + +- if (GET_CODE (str_rtx) == MEM && ! MEM_IN_STRUCT_P (str_rtx)) +- abort (); +- + /* Discount the part of the structure before the desired byte. + We need to know how many bytes are safe to reference after it. */ +--- 892,895 ---- +*************** expand_divmod (rem_flag, code, mode, op0 +*** 3189,3193 **** + Notice that we compute also the final remainder value here, + and return the result right away. */ +! if (target == 0) + target = gen_reg_rtx (compute_mode); + +--- 3202,3206 ---- + Notice that we compute also the final remainder value here, + and return the result right away. */ +! if (target == 0 || GET_MODE (target) != compute_mode) + target = gen_reg_rtx (compute_mode); + +*************** expand_divmod (rem_flag, code, mode, op0 +*** 3316,3320 **** + remainder. Notice that we compute also the final remainder + value here, and return the result right away. */ +! if (target == 0) + target = gen_reg_rtx (compute_mode); + +--- 3329,3333 ---- + remainder. Notice that we compute also the final remainder + value here, and return the result right away. */ +! if (target == 0 || GET_MODE (target) != compute_mode) + target = gen_reg_rtx (compute_mode); + +*************** expand_divmod (rem_flag, code, mode, op0 +*** 3418,3422 **** + remainder. Notice that we compute also the final remainder + value here, and return the result right away. */ +! if (target == 0) + target = gen_reg_rtx (compute_mode); + if (rem_flag) +--- 3431,3435 ---- + remainder. Notice that we compute also the final remainder + value here, and return the result right away. */ +! if (target == 0 || GET_MODE (target) != compute_mode) + target = gen_reg_rtx (compute_mode); + if (rem_flag) +*************** expand_divmod (rem_flag, code, mode, op0 +*** 3602,3605 **** +--- 3615,3621 ---- + if (quotient == 0) + { ++ if (target && GET_MODE (target) != compute_mode) ++ target = 0; ++ + if (rem_flag) + { +*************** expand_divmod (rem_flag, code, mode, op0 +*** 3653,3656 **** +--- 3669,3675 ---- + if (rem_flag) + { ++ if (target && GET_MODE (target) != compute_mode) ++ target = 0; ++ + if (quotient == 0) + /* No divide instruction either. Use library for remainder. */ +diff -rcp2N gcc-2.7.2.2/expr.c g77-new/expr.c +*** gcc-2.7.2.2/expr.c Thu Feb 20 19:24:17 1997 +--- g77-new/expr.c Sun Aug 10 18:47:21 1997 +*************** Boston, MA 02111-1307, USA. */ +*** 27,30 **** +--- 27,31 ---- + #include "flags.h" + #include "regs.h" ++ #include "hard-reg-set.h" + #include "function.h" + #include "insn-flags.h" +*************** extern int stack_depth; +*** 139,143 **** + extern int max_stack_depth; + extern struct obstack permanent_obstack; +! + + static rtx enqueue_insn PROTO((rtx, rtx)); +--- 140,144 ---- + extern int max_stack_depth; + extern struct obstack permanent_obstack; +! extern rtx arg_pointer_save_area; + + static rtx enqueue_insn PROTO((rtx, rtx)); +*************** expand_assignment (to, from, want_value, +*** 2498,2503 **** + + push_temp_slots (); +! tem = get_inner_reference (to, &bitsize, &bitpos, &offset, +! &mode1, &unsignedp, &volatilep); + + /* If we are going to use store_bit_field and extract_bit_field, +--- 2499,2504 ---- + + push_temp_slots (); +! tem = get_inner_reference (to, &bitsize, &bitpos, &offset, &mode1, +! &unsignedp, &volatilep, &alignment); + + /* If we are going to use store_bit_field and extract_bit_field, +*************** expand_assignment (to, from, want_value, +*** 2507,2511 **** + tem = stabilize_reference (tem); + +- alignment = TYPE_ALIGN (TREE_TYPE (tem)) / BITS_PER_UNIT; + to_rtx = expand_expr (tem, NULL_RTX, VOIDmode, 0); + if (offset != 0) +--- 2508,2511 ---- +*************** expand_assignment (to, from, want_value, +*** 2518,2529 **** + gen_rtx (PLUS, ptr_mode, XEXP (to_rtx, 0), + force_reg (ptr_mode, offset_rtx))); +- /* If we have a variable offset, the known alignment +- is only that of the innermost structure containing the field. +- (Actually, we could sometimes do better by using the +- align of an element of the innermost array, but no need.) */ +- if (TREE_CODE (to) == COMPONENT_REF +- || TREE_CODE (to) == BIT_FIELD_REF) +- alignment +- = TYPE_ALIGN (TREE_TYPE (TREE_OPERAND (to, 0))) / BITS_PER_UNIT; + } + if (volatilep) +--- 2518,2521 ---- +*************** store_expr (exp, target, want_value) +*** 2775,2780 **** + which will often result in some optimizations. Do the conversion + in two steps: first change the signedness, if needed, then +! the extend. */ +! if (! want_value) + { + if (TREE_UNSIGNED (TREE_TYPE (exp)) +--- 2767,2775 ---- + which will often result in some optimizations. Do the conversion + in two steps: first change the signedness, if needed, then +! the extend. But don't do this if the type of EXP is a subtype +! of something else since then the conversion might involve +! more than just converting modes. */ +! if (! want_value && INTEGRAL_TYPE_P (TREE_TYPE (exp)) +! && TREE_TYPE (TREE_TYPE (exp)) == 0) + { + if (TREE_UNSIGNED (TREE_TYPE (exp)) +*************** store_constructor (exp, target) +*** 3071,3074 **** +--- 3066,3077 ---- + } + ++ if (TREE_READONLY (field)) ++ { ++ if (GET_CODE (to_rtx) == MEM) ++ to_rtx = change_address (to_rtx, GET_MODE (to_rtx), ++ XEXP (to_rtx, 0)); ++ RTX_UNCHANGING_P (to_rtx) = 1; ++ } ++ + store_field (to_rtx, bitsize, bitpos, mode, TREE_VALUE (elt), + /* The alignment of TARGET is +*************** store_field (target, bitsize, bitpos, mo +*** 3414,3417 **** +--- 3417,3432 ---- + rtx temp = expand_expr (exp, NULL_RTX, VOIDmode, 0); + ++ /* If BITSIZE is narrower than the size of the type of EXP ++ we will be narrowing TEMP. Normally, what's wanted are the ++ low-order bits. However, if EXP's type is a record and this is ++ big-endian machine, we want the upper BITSIZE bits. */ ++ if (BYTES_BIG_ENDIAN && GET_MODE_CLASS (GET_MODE (temp)) == MODE_INT ++ && bitsize < GET_MODE_BITSIZE (GET_MODE (temp)) ++ && TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE) ++ temp = expand_shift (RSHIFT_EXPR, GET_MODE (temp), temp, ++ size_int (GET_MODE_BITSIZE (GET_MODE (temp)) ++ - bitsize), ++ temp, 1); ++ + /* Unless MODE is VOIDmode or BLKmode, convert TEMP to + MODE. */ +*************** store_field (target, bitsize, bitpos, mo +*** 3420,3423 **** +--- 3435,3459 ---- + temp = convert_modes (mode, TYPE_MODE (TREE_TYPE (exp)), temp, 1); + ++ /* If the modes of TARGET and TEMP are both BLKmode, both ++ must be in memory and BITPOS must be aligned on a byte ++ boundary. If so, we simply do a block copy. */ ++ if (GET_MODE (target) == BLKmode && GET_MODE (temp) == BLKmode) ++ { ++ if (GET_CODE (target) != MEM || GET_CODE (temp) != MEM ++ || bitpos % BITS_PER_UNIT != 0) ++ abort (); ++ ++ target = change_address (target, VOIDmode, ++ plus_constant (XEXP (target, 0), ++ bitpos / BITS_PER_UNIT)); ++ ++ emit_block_move (target, temp, ++ GEN_INT ((bitsize + BITS_PER_UNIT - 1) ++ / BITS_PER_UNIT), ++ 1); ++ ++ return value_mode == VOIDmode ? const0_rtx : target; ++ } ++ + /* Store the value in the bitfield. */ + store_bit_field (target, bitsize, bitpos, mode, temp, align, total_size); +*************** get_inner_unaligned_p (exp) +*** 3515,3518 **** +--- 3551,3557 ---- + This offset is in addition to the bit position. + If the position is not variable, we store 0 in *POFFSET. ++ We set *PALIGNMENT to the alignment in bytes of the address that will be ++ computed. This is the alignment of the thing we return if *POFFSET ++ is zero, but can be more less strictly aligned if *POFFSET is nonzero. + + If any of the extraction expressions is volatile, +*************** get_inner_unaligned_p (exp) +*** 3525,3533 **** + If the field describes a variable-sized object, *PMODE is set to + VOIDmode and *PBITSIZE is set to -1. An access cannot be made in +! this case, but the address of the object can be found. */ + + tree + get_inner_reference (exp, pbitsize, pbitpos, poffset, pmode, +! punsignedp, pvolatilep) + tree exp; + int *pbitsize; +--- 3564,3572 ---- + If the field describes a variable-sized object, *PMODE is set to + VOIDmode and *PBITSIZE is set to -1. An access cannot be made in +! this case, but the address of the object can be found. */ + + tree + get_inner_reference (exp, pbitsize, pbitpos, poffset, pmode, +! punsignedp, pvolatilep, palignment) + tree exp; + int *pbitsize; +*************** get_inner_reference (exp, pbitsize, pbit +*** 3537,3540 **** +--- 3576,3580 ---- + int *punsignedp; + int *pvolatilep; ++ int *palignment; + { + tree orig_exp = exp; +*************** get_inner_reference (exp, pbitsize, pbit +*** 3542,3545 **** +--- 3582,3586 ---- + enum machine_mode mode = VOIDmode; + tree offset = integer_zero_node; ++ int alignment = BIGGEST_ALIGNMENT; + + if (TREE_CODE (exp) == COMPONENT_REF) +*************** get_inner_reference (exp, pbitsize, pbit +*** 3599,3607 **** + + *pbitpos += TREE_INT_CST_LOW (constant); +! +! if (var) +! offset = size_binop (PLUS_EXPR, offset, +! size_binop (EXACT_DIV_EXPR, var, +! size_int (BITS_PER_UNIT))); + } + +--- 3640,3646 ---- + + *pbitpos += TREE_INT_CST_LOW (constant); +! offset = size_binop (PLUS_EXPR, offset, +! size_binop (EXACT_DIV_EXPR, var, +! size_int (BITS_PER_UNIT))); + } + +*************** get_inner_reference (exp, pbitsize, pbit +*** 3629,3633 **** + + index = fold (build (MULT_EXPR, index_type, index, +! TYPE_SIZE (TREE_TYPE (exp)))); + + if (TREE_CODE (index) == INTEGER_CST +--- 3668,3673 ---- + + index = fold (build (MULT_EXPR, index_type, index, +! convert (index_type, +! TYPE_SIZE (TREE_TYPE (exp))))); + + if (TREE_CODE (index) == INTEGER_CST +*************** get_inner_reference (exp, pbitsize, pbit +*** 3652,3666 **** + if (TREE_THIS_VOLATILE (exp)) + *pvolatilep = 1; + exp = TREE_OPERAND (exp, 0); + } + +! /* If this was a bit-field, see if there is a mode that allows direct +! access in case EXP is in memory. */ +! if (mode == VOIDmode && *pbitsize != 0 && *pbitpos % *pbitsize == 0) +! { +! mode = mode_for_size (*pbitsize, MODE_INT, 0); +! if (mode == BLKmode) +! mode = VOIDmode; +! } + + if (integer_zerop (offset)) +--- 3692,3708 ---- + if (TREE_THIS_VOLATILE (exp)) + *pvolatilep = 1; ++ ++ /* If the offset is non-constant already, then we can't assume any ++ alignment more than the alignment here. */ ++ if (! integer_zerop (offset)) ++ alignment = MIN (alignment, TYPE_ALIGN (TREE_TYPE (exp))); ++ + exp = TREE_OPERAND (exp, 0); + } + +! if (TREE_CODE_CLASS (TREE_CODE (exp)) == 'd') +! alignment = MIN (alignment, DECL_ALIGN (exp)); +! else if (TREE_TYPE (exp) != 0) +! alignment = MIN (alignment, TYPE_ALIGN (TREE_TYPE (exp))); + + if (integer_zerop (offset)) +*************** get_inner_reference (exp, pbitsize, pbit +*** 3672,3675 **** +--- 3714,3718 ---- + *pmode = mode; + *poffset = offset; ++ *palignment = alignment / BITS_PER_UNIT; + return exp; + } +*************** init_noncopied_parts (lhs, list) +*** 3812,3820 **** + } + +! /* Subroutine of expand_expr: return nonzero iff there is no way that + EXP can reference X, which is being modified. */ + + static int +! safe_from_p (x, exp) + rtx x; + tree exp; +--- 3855,3867 ---- + } + +! static int safe_from_p_count; +! static int safe_from_p_size; +! static tree *safe_from_p_rewritten; +! +! /* Subroutine of safe_from_p: return nonzero iff there is no way that + EXP can reference X, which is being modified. */ + + static int +! safe_from_p_1 (x, exp) + rtx x; + tree exp; +*************** safe_from_p (x, exp) +*** 3822,3825 **** +--- 3869,3873 ---- + rtx exp_rtl = 0; + int i, nops; ++ int is_save_expr = 0; + + if (x == 0 +*************** safe_from_p (x, exp) +*** 3860,3878 **** + + case 'x': +! if (TREE_CODE (exp) == TREE_LIST) +! return ((TREE_VALUE (exp) == 0 +! || safe_from_p (x, TREE_VALUE (exp))) +! && (TREE_CHAIN (exp) == 0 +! || safe_from_p (x, TREE_CHAIN (exp)))); +! else +! return 0; + + case '1': +! return safe_from_p (x, TREE_OPERAND (exp, 0)); + + case '2': + case '<': +! return (safe_from_p (x, TREE_OPERAND (exp, 0)) +! && safe_from_p (x, TREE_OPERAND (exp, 1))); + + case 'e': +--- 3908,3933 ---- + + case 'x': +! switch (TREE_CODE (exp)) +! { +! case TREE_LIST: +! return ((TREE_VALUE (exp) == 0 +! || safe_from_p_1 (x, TREE_VALUE (exp))) +! && (TREE_CHAIN (exp) == 0 +! || safe_from_p_1 (x, TREE_CHAIN (exp)))); +! +! case ERROR_MARK: +! return 1; +! +! default: +! return 0; +! } + + case '1': +! return safe_from_p_1 (x, TREE_OPERAND (exp, 0)); + + case '2': + case '<': +! return (safe_from_p_1 (x, TREE_OPERAND (exp, 0)) +! && safe_from_p_1 (x, TREE_OPERAND (exp, 1))); + + case 'e': +*************** safe_from_p (x, exp) +*** 3887,3891 **** + case ADDR_EXPR: + return (staticp (TREE_OPERAND (exp, 0)) +! || safe_from_p (x, TREE_OPERAND (exp, 0))); + + case INDIRECT_REF: +--- 3942,3946 ---- + case ADDR_EXPR: + return (staticp (TREE_OPERAND (exp, 0)) +! || safe_from_p_1 (x, TREE_OPERAND (exp, 0))); + + case INDIRECT_REF: +*************** safe_from_p (x, exp) +*** 3922,3928 **** + + case CLEANUP_POINT_EXPR: +! return safe_from_p (x, TREE_OPERAND (exp, 0)); + + case SAVE_EXPR: + exp_rtl = SAVE_EXPR_RTL (exp); + break; +--- 3977,3984 ---- + + case CLEANUP_POINT_EXPR: +! return safe_from_p_1 (x, TREE_OPERAND (exp, 0)); + + case SAVE_EXPR: ++ is_save_expr = 1; + exp_rtl = SAVE_EXPR_RTL (exp); + break; +*************** safe_from_p (x, exp) +*** 3931,3935 **** + /* The only operand we look at is operand 1. The rest aren't + part of the expression. */ +! return safe_from_p (x, TREE_OPERAND (exp, 1)); + + case METHOD_CALL_EXPR: +--- 3987,3991 ---- + /* The only operand we look at is operand 1. The rest aren't + part of the expression. */ +! return safe_from_p_1 (x, TREE_OPERAND (exp, 1)); + + case METHOD_CALL_EXPR: +*************** safe_from_p (x, exp) +*** 3945,3949 **** + for (i = 0; i < nops; i++) + if (TREE_OPERAND (exp, i) != 0 +! && ! safe_from_p (x, TREE_OPERAND (exp, i))) + return 0; + } +--- 4001,4005 ---- + for (i = 0; i < nops; i++) + if (TREE_OPERAND (exp, i) != 0 +! && ! safe_from_p_1 (x, TREE_OPERAND (exp, i))) + return 0; + } +*************** safe_from_p (x, exp) +*** 3969,3975 **** +--- 4025,4087 ---- + + /* If we reach here, it is safe. */ ++ if (is_save_expr) ++ { ++ /* This SAVE_EXPR might appear many times in the top-level ++ safe_from_p() expression, and if it has a complex ++ subexpression, examining it multiple times could result ++ in a combinatorial explosion. E.g. on an Alpha Cabriolet ++ running at least 200MHz, a Fortran test case compiled with ++ optimization took about 28 minutes to compile -- even though ++ it was only a few lines long, and the complicated line causing ++ so much time to be spent in the earlier version of safe_from_p() ++ had only 293 or so unique nodes. ++ ++ So, turn this SAVE_EXPR into an ERROR_MARK for now, but remember ++ where it is so we can turn it back in the top-level safe_from_p() ++ when we're done. */ ++ ++ if (safe_from_p_count > safe_from_p_size) ++ return 0; /* For now, don't bother re-sizing the array. */ ++ safe_from_p_rewritten[safe_from_p_count++] = exp; ++ TREE_SET_CODE (exp, ERROR_MARK); ++ } ++ + return 1; + } + ++ /* Subroutine of expand_expr: return nonzero iff there is no way that ++ EXP can reference X, which is being modified. */ ++ ++ static int ++ safe_from_p (x, exp) ++ rtx x; ++ tree exp; ++ { ++ int rtn; ++ int i; ++ tree trees[128]; ++ ++ safe_from_p_count = 0; ++ safe_from_p_size = sizeof (trees) / sizeof (trees[0]); ++ safe_from_p_rewritten = &trees[0]; ++ ++ rtn = safe_from_p_1 (x, exp); ++ ++ #if 0 ++ if (safe_from_p_count != 0) ++ fprintf (stderr, "%s:%d: safe_from_p_count = %d\n", ++ input_filename, lineno, safe_from_p_count); ++ #endif ++ ++ for (i = 0; i < safe_from_p_count; ++i) ++ { ++ if (TREE_CODE (trees [i]) != ERROR_MARK) ++ abort (); ++ TREE_SET_CODE (trees[i], SAVE_EXPR); ++ } ++ ++ return rtn; ++ } ++ + /* Subroutine of expand_expr: return nonzero iff EXP is an + expression whose type is statically determinable. */ +*************** expand_expr (exp, target, tmode, modifie +*** 4534,4537 **** +--- 4646,4658 ---- + } + } ++ ++ if (TREE_READONLY (exp)) ++ { ++ if (GET_CODE (target) == MEM) ++ target = change_address (target, GET_MODE (target), ++ XEXP (target, 0)); ++ RTX_UNCHANGING_P (target) = 1; ++ } ++ + store_constructor (exp, target); + return target; +*************** expand_expr (exp, target, tmode, modifie +*** 4543,4567 **** + tree exp2; + +! /* A SAVE_EXPR as the address in an INDIRECT_EXPR is generated +! for *PTR += ANYTHING where PTR is put inside the SAVE_EXPR. +! This code has the same general effect as simply doing +! expand_expr on the save expr, except that the expression PTR +! is computed for use as a memory address. This means different +! code, suitable for indexing, may be generated. */ +! if (TREE_CODE (exp1) == SAVE_EXPR +! && SAVE_EXPR_RTL (exp1) == 0 +! && TYPE_MODE (TREE_TYPE (exp1)) == ptr_mode) +! { +! temp = expand_expr (TREE_OPERAND (exp1, 0), NULL_RTX, +! VOIDmode, EXPAND_SUM); +! op0 = memory_address (mode, temp); +! op0 = copy_all_regs (op0); +! SAVE_EXPR_RTL (exp1) = op0; +! } +! else +! { +! op0 = expand_expr (exp1, NULL_RTX, VOIDmode, EXPAND_SUM); +! op0 = memory_address (mode, op0); +! } + + temp = gen_rtx (MEM, mode, op0); +--- 4664,4669 ---- + tree exp2; + +! op0 = expand_expr (exp1, NULL_RTX, VOIDmode, EXPAND_SUM); +! op0 = memory_address (mode, op0); + + temp = gen_rtx (MEM, mode, op0); +*************** expand_expr (exp, target, tmode, modifie +*** 4770,4776 **** + tree offset; + int volatilep = 0; +- tree tem = get_inner_reference (exp, &bitsize, &bitpos, &offset, +- &mode1, &unsignedp, &volatilep); + int alignment; + + /* If we got back the original object, something is wrong. Perhaps +--- 4872,4879 ---- + tree offset; + int volatilep = 0; + int alignment; ++ tree tem = get_inner_reference (exp, &bitsize, &bitpos, &offset, ++ &mode1, &unsignedp, &volatilep, ++ &alignment); + + /* If we got back the original object, something is wrong. Perhaps +*************** expand_expr (exp, target, tmode, modifie +*** 4793,4797 **** + != INTEGER_CST) + ? target : NULL_RTX), +! VOIDmode, EXPAND_SUM); + + /* If this is a constant, put it into a register if it is a +--- 4896,4901 ---- + != INTEGER_CST) + ? target : NULL_RTX), +! VOIDmode, +! modifier == EXPAND_INITIALIZER ? modifier : 0); + + /* If this is a constant, put it into a register if it is a +*************** expand_expr (exp, target, tmode, modifie +*** 4806,4810 **** + } + +- alignment = TYPE_ALIGN (TREE_TYPE (tem)) / BITS_PER_UNIT; + if (offset != 0) + { +--- 4910,4913 ---- +*************** expand_expr (exp, target, tmode, modifie +*** 4816,4827 **** + gen_rtx (PLUS, ptr_mode, XEXP (op0, 0), + force_reg (ptr_mode, offset_rtx))); +- /* If we have a variable offset, the known alignment +- is only that of the innermost structure containing the field. +- (Actually, we could sometimes do better by using the +- size of an element of the innermost array, but no need.) */ +- if (TREE_CODE (exp) == COMPONENT_REF +- || TREE_CODE (exp) == BIT_FIELD_REF) +- alignment = (TYPE_ALIGN (TREE_TYPE (TREE_OPERAND (exp, 0))) +- / BITS_PER_UNIT); + } + +--- 4919,4922 ---- +*************** expand_expr (exp, target, tmode, modifie +*** 4844,4848 **** + && modifier != EXPAND_SUM + && modifier != EXPAND_INITIALIZER +! && ((mode1 != BLKmode && ! direct_load[(int) mode1]) + /* If the field isn't aligned enough to fetch as a memref, + fetch it as a bit field. */ +--- 4939,4945 ---- + && modifier != EXPAND_SUM + && modifier != EXPAND_INITIALIZER +! && ((mode1 != BLKmode && ! direct_load[(int) mode1] +! && GET_MODE_CLASS (mode) != MODE_COMPLEX_INT +! && GET_MODE_CLASS (mode) != MODE_COMPLEX_FLOAT) + /* If the field isn't aligned enough to fetch as a memref, + fetch it as a bit field. */ +*************** expand_expr (exp, target, tmode, modifie +*** 4857,4861 **** + + if (ext_mode == BLKmode) +! abort (); + + op0 = extract_bit_field (validize_mem (op0), bitsize, bitpos, +--- 4954,4982 ---- + + if (ext_mode == BLKmode) +! { +! /* In this case, BITPOS must start at a byte boundary and +! TARGET, if specified, must be a MEM. */ +! if (GET_CODE (op0) != MEM +! || (target != 0 && GET_CODE (target) != MEM) +! || bitpos % BITS_PER_UNIT != 0) +! abort (); +! +! op0 = change_address (op0, VOIDmode, +! plus_constant (XEXP (op0, 0), +! bitpos / BITS_PER_UNIT)); +! if (target == 0) +! { +! target +! = assign_stack_temp (mode, int_size_in_bytes (type), 0); +! MEM_IN_STRUCT_P (target) = AGGREGATE_TYPE_P (type); +! } +! +! emit_block_move (target, op0, +! GEN_INT ((bitsize + BITS_PER_UNIT - 1) +! / BITS_PER_UNIT), +! 1); +! +! return target; +! } + + op0 = extract_bit_field (validize_mem (op0), bitsize, bitpos, +*************** expand_expr (exp, target, tmode, modifie +*** 4863,4866 **** +--- 4984,4999 ---- + alignment, + int_size_in_bytes (TREE_TYPE (tem))); ++ ++ /* If the result is a record type and BITSIZE is narrower than ++ the mode of OP0, an integral mode, and this is a big endian ++ machine, we must put the field into the high-order bits. */ ++ if (TREE_CODE (type) == RECORD_TYPE && BYTES_BIG_ENDIAN ++ && GET_MODE_CLASS (GET_MODE (op0)) == MODE_INT ++ && bitsize < GET_MODE_BITSIZE (GET_MODE (op0))) ++ op0 = expand_shift (LSHIFT_EXPR, GET_MODE (op0), op0, ++ size_int (GET_MODE_BITSIZE (GET_MODE (op0)) ++ - bitsize), ++ op0, 1); ++ + if (mode == BLKmode) + { +*************** expand_expr (exp, target, tmode, modifie +*** 4877,4880 **** +--- 5010,5018 ---- + } + ++ /* If the result is BLKmode, use that to access the object ++ now as well. */ ++ if (mode == BLKmode) ++ mode1 = BLKmode; ++ + /* Get a reference to just this component. */ + if (modifier == EXPAND_CONST_ADDRESS +*************** expand_expr (exp, target, tmode, modifie +*** 4888,4895 **** + MEM_IN_STRUCT_P (op0) = 1; + MEM_VOLATILE_P (op0) |= volatilep; +! if (mode == mode1 || mode1 == BLKmode || mode1 == tmode) + return op0; +! if (target == 0) + target = gen_reg_rtx (tmode != VOIDmode ? tmode : mode); + convert_move (target, op0, unsignedp); + return target; +--- 5026,5036 ---- + MEM_IN_STRUCT_P (op0) = 1; + MEM_VOLATILE_P (op0) |= volatilep; +! if (mode == mode1 || mode1 == BLKmode || mode1 == tmode +! || modifier == EXPAND_CONST_ADDRESS +! || modifier == EXPAND_INITIALIZER) + return op0; +! else if (target == 0) + target = gen_reg_rtx (tmode != VOIDmode ? tmode : mode); ++ + convert_move (target, op0, unsignedp); + return target; +*************** expand_builtin (exp, target, subtarget, +*** 7986,7989 **** +--- 8127,8365 ---- + #endif + ++ /* __builtin_setjmp is passed a pointer to an array of five words ++ (not all will be used on all machines). It operates similarly to ++ the C library function of the same name, but is more efficient. ++ Much of the code below (and for longjmp) is copied from the handling ++ of non-local gotos. ++ ++ NOTE: This is intended for use by GNAT and will only work in ++ the method used by it. This code will likely NOT survive to ++ the GCC 2.8.0 release. */ ++ case BUILT_IN_SETJMP: ++ if (arglist == 0 ++ || TREE_CODE (TREE_TYPE (TREE_VALUE (arglist))) != POINTER_TYPE) ++ break; ++ ++ { ++ rtx buf_addr = expand_expr (TREE_VALUE (arglist), subtarget, ++ VOIDmode, 0); ++ rtx lab1 = gen_label_rtx (), lab2 = gen_label_rtx (); ++ enum machine_mode sa_mode = Pmode; ++ rtx stack_save; ++ int old_inhibit_defer_pop = inhibit_defer_pop; ++ int return_pops = RETURN_POPS_ARGS (get_identifier ("__dummy"), ++ get_identifier ("__dummy"), 0); ++ rtx next_arg_reg; ++ CUMULATIVE_ARGS args_so_far; ++ int current_call_is_indirect = 1; ++ int i; ++ ++ #ifdef POINTERS_EXTEND_UNSIGNED ++ buf_addr = convert_memory_address (Pmode, buf_addr); ++ #endif ++ ++ buf_addr = force_reg (Pmode, buf_addr); ++ ++ if (target == 0 || GET_CODE (target) != REG ++ || REGNO (target) < FIRST_PSEUDO_REGISTER) ++ target = gen_reg_rtx (value_mode); ++ ++ emit_queue (); ++ ++ CONST_CALL_P (emit_note (NULL_PTR, NOTE_INSN_SETJMP)) = 1; ++ current_function_calls_setjmp = 1; ++ ++ /* We store the frame pointer and the address of lab1 in the buffer ++ and use the rest of it for the stack save area, which is ++ machine-dependent. */ ++ emit_move_insn (gen_rtx (MEM, Pmode, buf_addr), ++ virtual_stack_vars_rtx); ++ emit_move_insn ++ (validize_mem (gen_rtx (MEM, Pmode, ++ plus_constant (buf_addr, ++ GET_MODE_SIZE (Pmode)))), ++ gen_rtx (LABEL_REF, Pmode, lab1)); ++ ++ #ifdef HAVE_save_stack_nonlocal ++ if (HAVE_save_stack_nonlocal) ++ sa_mode = insn_operand_mode[(int) CODE_FOR_save_stack_nonlocal][0]; ++ #endif ++ ++ current_function_has_nonlocal_goto = 1; ++ ++ stack_save = gen_rtx (MEM, sa_mode, ++ plus_constant (buf_addr, ++ 2 * GET_MODE_SIZE (Pmode))); ++ emit_stack_save (SAVE_NONLOCAL, &stack_save, NULL_RTX); ++ ++ #ifdef HAVE_setjmp ++ if (HAVE_setjmp) ++ emit_insn (gen_setjmp ()); ++ #endif ++ ++ /* Set TARGET to zero and branch around the other case. */ ++ emit_move_insn (target, const0_rtx); ++ emit_jump_insn (gen_jump (lab2)); ++ emit_barrier (); ++ emit_label (lab1); ++ ++ /* Note that setjmp clobbers FP when we get here, so we have to ++ make sure it's marked as used by this function. */ ++ emit_insn (gen_rtx (USE, VOIDmode, hard_frame_pointer_rtx)); ++ ++ /* Mark the static chain as clobbered here so life information ++ doesn't get messed up for it. */ ++ emit_insn (gen_rtx (CLOBBER, VOIDmode, static_chain_rtx)); ++ ++ /* Now put in the code to restore the frame pointer, and argument ++ pointer, if needed. The code below is from expand_end_bindings ++ in stmt.c; see detailed documentation there. */ ++ #ifdef HAVE_nonlocal_goto ++ if (! HAVE_nonlocal_goto) ++ #endif ++ emit_move_insn (virtual_stack_vars_rtx, hard_frame_pointer_rtx); ++ ++ #if ARG_POINTER_REGNUM != HARD_FRAME_POINTER_REGNUM ++ if (fixed_regs[ARG_POINTER_REGNUM]) ++ { ++ #ifdef ELIMINABLE_REGS ++ static struct elims {int from, to;} elim_regs[] = ELIMINABLE_REGS; ++ ++ for (i = 0; i < sizeof elim_regs / sizeof elim_regs[0]; i++) ++ if (elim_regs[i].from == ARG_POINTER_REGNUM ++ && elim_regs[i].to == HARD_FRAME_POINTER_REGNUM) ++ break; ++ ++ if (i == sizeof elim_regs / sizeof elim_regs [0]) ++ #endif ++ { ++ /* Now restore our arg pointer from the address at which it ++ was saved in our stack frame. ++ If there hasn't be space allocated for it yet, make ++ some now. */ ++ if (arg_pointer_save_area == 0) ++ arg_pointer_save_area ++ = assign_stack_local (Pmode, GET_MODE_SIZE (Pmode), 0); ++ emit_move_insn (virtual_incoming_args_rtx, ++ copy_to_reg (arg_pointer_save_area)); ++ } ++ } ++ #endif ++ ++ #ifdef HAVE_nonlocal_goto_receiver ++ if (HAVE_nonlocal_goto_receiver) ++ emit_insn (gen_nonlocal_goto_receiver ()); ++ #endif ++ /* The static chain pointer contains the address of dummy function. ++ We need to call it here to handle some PIC cases of restoring ++ a global pointer. Then return 1. */ ++ op0 = copy_to_mode_reg (Pmode, static_chain_rtx); ++ ++ /* We can't actually call emit_library_call here, so do everything ++ it does, which isn't much for a libfunc with no args. */ ++ op0 = memory_address (FUNCTION_MODE, op0); ++ ++ INIT_CUMULATIVE_ARGS (args_so_far, NULL_TREE, ++ gen_rtx (SYMBOL_REF, Pmode, "__dummy")); ++ next_arg_reg = FUNCTION_ARG (args_so_far, VOIDmode, void_type_node, 1); ++ ++ #ifndef ACCUMULATE_OUTGOING_ARGS ++ #ifdef HAVE_call_pop ++ if (HAVE_call_pop) ++ emit_call_insn (gen_call_pop (gen_rtx (MEM, FUNCTION_MODE, op0), ++ const0_rtx, next_arg_reg, ++ GEN_INT (return_pops))); ++ else ++ #endif ++ #endif ++ ++ #ifdef HAVE_call ++ if (HAVE_call) ++ emit_call_insn (gen_call (gen_rtx (MEM, FUNCTION_MODE, op0), ++ const0_rtx, next_arg_reg, const0_rtx)); ++ else ++ #endif ++ abort (); ++ ++ emit_move_insn (target, const1_rtx); ++ emit_label (lab2); ++ return target; ++ } ++ ++ /* __builtin_longjmp is passed a pointer to an array of five words ++ and a value, which is a dummy. It's similar to the C library longjmp ++ function but works with __builtin_setjmp above. */ ++ case BUILT_IN_LONGJMP: ++ if (arglist == 0 || TREE_CHAIN (arglist) == 0 ++ || TREE_CODE (TREE_TYPE (TREE_VALUE (arglist))) != POINTER_TYPE) ++ break; ++ ++ { ++ tree dummy_id = get_identifier ("__dummy"); ++ tree dummy_type = build_function_type (void_type_node, NULL_TREE); ++ tree dummy_decl = build_decl (FUNCTION_DECL, dummy_id, dummy_type); ++ #ifdef POINTERS_EXTEND_UNSIGNED ++ rtx buf_addr ++ = force_reg (Pmode, ++ convert_memory_address ++ (Pmode, ++ expand_expr (TREE_VALUE (arglist), ++ NULL_RTX, VOIDmode, 0))); ++ #else ++ rtx buf_addr ++ = force_reg (Pmode, expand_expr (TREE_VALUE (arglist), ++ NULL_RTX, ++ VOIDmode, 0)); ++ #endif ++ rtx fp = gen_rtx (MEM, Pmode, buf_addr); ++ rtx lab = gen_rtx (MEM, Pmode, ++ plus_constant (buf_addr, GET_MODE_SIZE (Pmode))); ++ enum machine_mode sa_mode ++ #ifdef HAVE_save_stack_nonlocal ++ = (HAVE_save_stack_nonlocal ++ ? insn_operand_mode[(int) CODE_FOR_save_stack_nonlocal][0] ++ : Pmode); ++ #else ++ = Pmode; ++ #endif ++ rtx stack = gen_rtx (MEM, sa_mode, ++ plus_constant (buf_addr, ++ 2 * GET_MODE_SIZE (Pmode))); ++ ++ DECL_EXTERNAL (dummy_decl) = 1; ++ TREE_PUBLIC (dummy_decl) = 1; ++ make_decl_rtl (dummy_decl, NULL_PTR, 1); ++ ++ /* Expand the second expression just for side-effects. */ ++ expand_expr (TREE_VALUE (TREE_CHAIN (arglist)), ++ const0_rtx, VOIDmode, 0); ++ ++ assemble_external (dummy_decl); ++ ++ /* Pick up FP, label, and SP from the block and jump. This code is ++ from expand_goto in stmt.c; see there for detailed comments. */ ++ #if HAVE_nonlocal_goto ++ if (HAVE_nonlocal_goto) ++ emit_insn (gen_nonlocal_goto (fp, lab, stack, ++ XEXP (DECL_RTL (dummy_decl), 0))); ++ else ++ #endif ++ { ++ lab = copy_to_reg (lab); ++ emit_move_insn (hard_frame_pointer_rtx, fp); ++ emit_stack_restore (SAVE_NONLOCAL, stack, NULL_RTX); ++ ++ /* Put in the static chain register the address of the dummy ++ function. */ ++ emit_move_insn (static_chain_rtx, XEXP (DECL_RTL (dummy_decl), 0)); ++ emit_insn (gen_rtx (USE, VOIDmode, hard_frame_pointer_rtx)); ++ emit_insn (gen_rtx (USE, VOIDmode, stack_pointer_rtx)); ++ emit_insn (gen_rtx (USE, VOIDmode, static_chain_rtx)); ++ emit_indirect_jump (lab); ++ } ++ ++ return const0_rtx; ++ } ++ + default: /* just do library call, if unknown builtin */ + error ("built-in function `%s' not currently supported", +*************** preexpand_calls (exp) +*** 8688,8701 **** + case CALL_EXPR: + /* Do nothing if already expanded. */ +! if (CALL_EXPR_RTL (exp) != 0) + return; + +! /* Do nothing to built-in functions. */ +! if (TREE_CODE (TREE_OPERAND (exp, 0)) != ADDR_EXPR +! || TREE_CODE (TREE_OPERAND (TREE_OPERAND (exp, 0), 0)) != FUNCTION_DECL +! || ! DECL_BUILT_IN (TREE_OPERAND (TREE_OPERAND (exp, 0), 0)) +! /* Do nothing if the call returns a variable-sized object. */ +! || TREE_CODE (TYPE_SIZE (TREE_TYPE(exp))) != INTEGER_CST) +! CALL_EXPR_RTL (exp) = expand_call (exp, NULL_RTX, 0); + return; + +--- 9064,9078 ---- + case CALL_EXPR: + /* Do nothing if already expanded. */ +! if (CALL_EXPR_RTL (exp) != 0 +! /* Do nothing if the call returns a variable-sized object. */ +! || TREE_CODE (TYPE_SIZE (TREE_TYPE(exp))) != INTEGER_CST +! /* Do nothing to built-in functions. */ +! || (TREE_CODE (TREE_OPERAND (exp, 0)) == ADDR_EXPR +! && (TREE_CODE (TREE_OPERAND (TREE_OPERAND (exp, 0), 0)) +! == FUNCTION_DECL) +! && DECL_BUILT_IN (TREE_OPERAND (TREE_OPERAND (exp, 0), 0)))) + return; + +! CALL_EXPR_RTL (exp) = expand_call (exp, NULL_RTX, 0); + return; + +*************** do_jump (exp, if_false_label, if_true_la +*** 9087,9090 **** +--- 9464,9468 ---- + push_temp_slots (); + expand_expr (TREE_OPERAND (exp, 0), const0_rtx, VOIDmode, 0); ++ preserve_temp_slots (NULL_RTX); + free_temp_slots (); + pop_temp_slots (); +*************** do_jump (exp, if_false_label, if_true_la +*** 9103,9111 **** + tree offset; + int volatilep = 0; + + /* Get description of this reference. We don't actually care + about the underlying object here. */ + get_inner_reference (exp, &bitsize, &bitpos, &offset, +! &mode, &unsignedp, &volatilep); + + type = type_for_size (bitsize, unsignedp); +--- 9481,9491 ---- + tree offset; + int volatilep = 0; ++ int alignment; + + /* Get description of this reference. We don't actually care + about the underlying object here. */ + get_inner_reference (exp, &bitsize, &bitpos, &offset, +! &mode, &unsignedp, &volatilep, +! &alignment); + + type = type_for_size (bitsize, unsignedp); +diff -rcp2N gcc-2.7.2.2/final.c g77-new/final.c +*** gcc-2.7.2.2/final.c Sun Nov 26 13:50:00 1995 +--- g77-new/final.c Thu Jul 10 20:11:16 1997 +*************** profile_function (file) +*** 983,991 **** + text_section (); + +! #ifdef STRUCT_VALUE_INCOMING_REGNUM + if (sval) + ASM_OUTPUT_REG_PUSH (file, STRUCT_VALUE_INCOMING_REGNUM); + #else +! #ifdef STRUCT_VALUE_REGNUM + if (sval) + ASM_OUTPUT_REG_PUSH (file, STRUCT_VALUE_REGNUM); +--- 983,991 ---- + text_section (); + +! #if defined(STRUCT_VALUE_INCOMING_REGNUM) && defined(ASM_OUTPUT_REG_PUSH) + if (sval) + ASM_OUTPUT_REG_PUSH (file, STRUCT_VALUE_INCOMING_REGNUM); + #else +! #if defined(STRUCT_VALUE_REGNUM) && defined(ASM_OUTPUT_REG_PUSH) + if (sval) + ASM_OUTPUT_REG_PUSH (file, STRUCT_VALUE_REGNUM); +*************** profile_function (file) +*** 993,1027 **** + #endif + +! #if 0 +! #ifdef STATIC_CHAIN_INCOMING_REGNUM + if (cxt) + ASM_OUTPUT_REG_PUSH (file, STATIC_CHAIN_INCOMING_REGNUM); + #else +! #ifdef STATIC_CHAIN_REGNUM + if (cxt) + ASM_OUTPUT_REG_PUSH (file, STATIC_CHAIN_REGNUM); + #endif + #endif +- #endif /* 0 */ + + FUNCTION_PROFILER (file, profile_label_no); + +! #if 0 +! #ifdef STATIC_CHAIN_INCOMING_REGNUM + if (cxt) + ASM_OUTPUT_REG_POP (file, STATIC_CHAIN_INCOMING_REGNUM); + #else +! #ifdef STATIC_CHAIN_REGNUM + if (cxt) + ASM_OUTPUT_REG_POP (file, STATIC_CHAIN_REGNUM); + #endif + #endif +- #endif /* 0 */ + +! #ifdef STRUCT_VALUE_INCOMING_REGNUM + if (sval) + ASM_OUTPUT_REG_POP (file, STRUCT_VALUE_INCOMING_REGNUM); + #else +! #ifdef STRUCT_VALUE_REGNUM + if (sval) + ASM_OUTPUT_REG_POP (file, STRUCT_VALUE_REGNUM); +--- 993,1023 ---- + #endif + +! #if defined(STATIC_CHAIN_INCOMING_REGNUM) && defined(ASM_OUTPUT_REG_PUSH) + if (cxt) + ASM_OUTPUT_REG_PUSH (file, STATIC_CHAIN_INCOMING_REGNUM); + #else +! #if defined(STATIC_CHAIN_REGNUM) && defined(ASM_OUTPUT_REG_PUSH) + if (cxt) + ASM_OUTPUT_REG_PUSH (file, STATIC_CHAIN_REGNUM); + #endif + #endif + + FUNCTION_PROFILER (file, profile_label_no); + +! #if defined(STATIC_CHAIN_INCOMING_REGNUM) && defined(ASM_OUTPUT_REG_PUSH) + if (cxt) + ASM_OUTPUT_REG_POP (file, STATIC_CHAIN_INCOMING_REGNUM); + #else +! #if defined(STATIC_CHAIN_REGNUM) && defined(ASM_OUTPUT_REG_PUSH) + if (cxt) + ASM_OUTPUT_REG_POP (file, STATIC_CHAIN_REGNUM); + #endif + #endif + +! #if defined(STRUCT_VALUE_INCOMING_REGNUM) && defined(ASM_OUTPUT_REG_PUSH) + if (sval) + ASM_OUTPUT_REG_POP (file, STRUCT_VALUE_INCOMING_REGNUM); + #else +! #if defined(STRUCT_VALUE_REGNUM) && defined(ASM_OUTPUT_REG_PUSH) + if (sval) + ASM_OUTPUT_REG_POP (file, STRUCT_VALUE_REGNUM); +diff -rcp2N gcc-2.7.2.2/flags.h g77-new/flags.h +*** gcc-2.7.2.2/flags.h Thu Jun 15 07:34:11 1995 +--- g77-new/flags.h Thu Jul 10 20:08:56 1997 +*************** extern int flag_unroll_loops; +*** 204,207 **** +--- 204,221 ---- + extern int flag_unroll_all_loops; + ++ /* Nonzero forces all invariant computations in loops to be moved ++ outside the loop. */ ++ ++ extern int flag_move_all_movables; ++ ++ /* Nonzero forces all general induction variables in loops to be ++ strength reduced. */ ++ ++ extern int flag_reduce_all_givs; ++ ++ /* Nonzero gets another run of loop_optimize performed. */ ++ ++ extern int flag_rerun_loop_opt; ++ + /* Nonzero for -fcse-follow-jumps: + have cse follow jumps to do a more extensive job. */ +*************** extern int flag_gnu_linker; +*** 339,342 **** +--- 353,369 ---- + /* Tag all structures with __attribute__(packed) */ + extern int flag_pack_struct; ++ ++ /* 1 if alias checking is enabled: symbols do not alias each other ++ and parameters do not alias the current stack frame. */ ++ extern int flag_alias_check; ++ ++ /* This flag is only tested if alias checking is enabled. ++ 0 if pointer arguments may alias each other. True in C. ++ 1 if pointer arguments may not alias each other but may alias ++ global variables. ++ 2 if pointer arguments may not alias each other and may not ++ alias global variables. True in Fortran. ++ The value is ignored if flag_alias_check is 0. */ ++ extern int flag_argument_noalias; + + /* Other basic status info about current function. */ +diff -rcp2N gcc-2.7.2.2/flow.c g77-new/flow.c +*** gcc-2.7.2.2/flow.c Mon Aug 28 06:23:34 1995 +--- g77-new/flow.c Sun Aug 10 18:46:11 1997 +*************** static HARD_REG_SET elim_reg_set; +*** 288,292 **** + /* Forward declarations */ + static void find_basic_blocks PROTO((rtx, rtx)); +! static int uses_reg_or_mem PROTO((rtx)); + static void mark_label_ref PROTO((rtx, rtx, int)); + static void life_analysis PROTO((rtx, int)); +--- 288,292 ---- + /* Forward declarations */ + static void find_basic_blocks PROTO((rtx, rtx)); +! static int jmp_uses_reg_or_mem PROTO((rtx)); + static void mark_label_ref PROTO((rtx, rtx, int)); + static void life_analysis PROTO((rtx, int)); +*************** find_basic_blocks (f, nonlocal_label_lis +*** 554,563 **** + if (GET_CODE (XVECEXP (pat, 0, i)) == SET + && SET_DEST (XVECEXP (pat, 0, i)) == pc_rtx +! && uses_reg_or_mem (SET_SRC (XVECEXP (pat, 0, i)))) + computed_jump = 1; + } + else if (GET_CODE (pat) == SET + && SET_DEST (pat) == pc_rtx +! && uses_reg_or_mem (SET_SRC (pat))) + computed_jump = 1; + +--- 554,563 ---- + if (GET_CODE (XVECEXP (pat, 0, i)) == SET + && SET_DEST (XVECEXP (pat, 0, i)) == pc_rtx +! && jmp_uses_reg_or_mem (SET_SRC (XVECEXP (pat, 0, i)))) + computed_jump = 1; + } + else if (GET_CODE (pat) == SET + && SET_DEST (pat) == pc_rtx +! && jmp_uses_reg_or_mem (SET_SRC (pat))) + computed_jump = 1; + +*************** find_basic_blocks (f, nonlocal_label_lis +*** 760,767 **** + /* Subroutines of find_basic_blocks. */ + +! /* Return 1 if X contain a REG or MEM that is not in the constant pool. */ + + static int +! uses_reg_or_mem (x) + rtx x; + { +--- 760,768 ---- + /* Subroutines of find_basic_blocks. */ + +! /* Return 1 if X, the SRC_SRC of SET of (pc) contain a REG or MEM that is +! not in the constant pool and not in the condition of an IF_THEN_ELSE. */ + + static int +! jmp_uses_reg_or_mem (x) + rtx x; + { +*************** uses_reg_or_mem (x) +*** 770,778 **** + char *fmt; + +! if (code == REG +! || (code == MEM +! && ! (GET_CODE (XEXP (x, 0)) == SYMBOL_REF +! && CONSTANT_POOL_ADDRESS_P (XEXP (x, 0))))) +! return 1; + + fmt = GET_RTX_FORMAT (code); +--- 771,796 ---- + char *fmt; + +! switch (code) +! { +! case CONST: +! case LABEL_REF: +! case PC: +! return 0; +! +! case REG: +! return 1; +! +! case MEM: +! return ! (GET_CODE (XEXP (x, 0)) == SYMBOL_REF +! && CONSTANT_POOL_ADDRESS_P (XEXP (x, 0))); +! +! case IF_THEN_ELSE: +! return (jmp_uses_reg_or_mem (XEXP (x, 1)) +! || jmp_uses_reg_or_mem (XEXP (x, 2))); +! +! case PLUS: case MINUS: case MULT: +! return (jmp_uses_reg_or_mem (XEXP (x, 0)) +! || jmp_uses_reg_or_mem (XEXP (x, 1))); +! } + + fmt = GET_RTX_FORMAT (code); +*************** uses_reg_or_mem (x) +*** 780,789 **** + { + if (fmt[i] == 'e' +! && uses_reg_or_mem (XEXP (x, i))) + return 1; + + if (fmt[i] == 'E') + for (j = 0; j < XVECLEN (x, i); j++) +! if (uses_reg_or_mem (XVECEXP (x, i, j))) + return 1; + } +--- 798,807 ---- + { + if (fmt[i] == 'e' +! && jmp_uses_reg_or_mem (XEXP (x, i))) + return 1; + + if (fmt[i] == 'E') + for (j = 0; j < XVECLEN (x, i); j++) +! if (jmp_uses_reg_or_mem (XVECEXP (x, i, j))) + return 1; + } +*************** propagate_block (old, first, last, final +*** 1605,1614 **** + + /* Each call clobbers all call-clobbered regs that are not +! global. Note that the function-value reg is a + call-clobbered reg, and mark_set_regs has already had + a chance to handle it. */ + + for (i = 0; i < FIRST_PSEUDO_REGISTER; i++) +! if (call_used_regs[i] && ! global_regs[i]) + dead[i / REGSET_ELT_BITS] + |= ((REGSET_ELT_TYPE) 1 << (i % REGSET_ELT_BITS)); +--- 1623,1633 ---- + + /* Each call clobbers all call-clobbered regs that are not +! global or fixed. Note that the function-value reg is a + call-clobbered reg, and mark_set_regs has already had + a chance to handle it. */ + + for (i = 0; i < FIRST_PSEUDO_REGISTER; i++) +! if (call_used_regs[i] && ! global_regs[i] +! && ! fixed_regs[i]) + dead[i / REGSET_ELT_BITS] + |= ((REGSET_ELT_TYPE) 1 << (i % REGSET_ELT_BITS)); +diff -rcp2N gcc-2.7.2.2/fold-const.c g77-new/fold-const.c +*** gcc-2.7.2.2/fold-const.c Fri Sep 15 18:26:12 1995 +--- g77-new/fold-const.c Sun Aug 10 18:47:18 1997 +*************** static tree unextend PROTO((tree, int, i +*** 80,83 **** +--- 80,84 ---- + static tree fold_truthop PROTO((enum tree_code, tree, tree, tree)); + static tree strip_compound_expr PROTO((tree, tree)); ++ static int multiple_of_p PROTO((tree, tree, tree)); + + #ifndef BRANCH_COST +*************** const_binop (code, arg1, arg2, notrunc) +*** 1077,1080 **** +--- 1078,1083 ---- + if (int2h == 0 && int2l > 0 + && TREE_TYPE (arg1) == sizetype ++ && ! TREE_CONSTANT_OVERFLOW (arg1) ++ && ! TREE_CONSTANT_OVERFLOW (arg2) + && int1h == 0 && int1l >= 0) + { +*************** const_binop (code, arg1, arg2, notrunc) +*** 1230,1233 **** +--- 1233,1237 ---- + if (TREE_CODE (arg1) == COMPLEX_CST) + { ++ register tree type = TREE_TYPE (arg1); + register tree r1 = TREE_REALPART (arg1); + register tree i1 = TREE_IMAGPART (arg1); +*************** const_binop (code, arg1, arg2, notrunc) +*** 1239,1253 **** + { + case PLUS_EXPR: +! t = build_complex (const_binop (PLUS_EXPR, r1, r2, notrunc), + const_binop (PLUS_EXPR, i1, i2, notrunc)); + break; + + case MINUS_EXPR: +! t = build_complex (const_binop (MINUS_EXPR, r1, r2, notrunc), + const_binop (MINUS_EXPR, i1, i2, notrunc)); + break; + + case MULT_EXPR: +! t = build_complex (const_binop (MINUS_EXPR, + const_binop (MULT_EXPR, + r1, r2, notrunc), +--- 1243,1260 ---- + { + case PLUS_EXPR: +! t = build_complex (type, +! const_binop (PLUS_EXPR, r1, r2, notrunc), + const_binop (PLUS_EXPR, i1, i2, notrunc)); + break; + + case MINUS_EXPR: +! t = build_complex (type, +! const_binop (MINUS_EXPR, r1, r2, notrunc), + const_binop (MINUS_EXPR, i1, i2, notrunc)); + break; + + case MULT_EXPR: +! t = build_complex (type, +! const_binop (MINUS_EXPR, + const_binop (MULT_EXPR, + r1, r2, notrunc), +*************** const_binop (code, arg1, arg2, notrunc) +*** 1271,1293 **** + notrunc); + +! t = build_complex +! (const_binop (INTEGRAL_TYPE_P (TREE_TYPE (r1)) +! ? TRUNC_DIV_EXPR : RDIV_EXPR, +! const_binop (PLUS_EXPR, +! const_binop (MULT_EXPR, r1, r2, +! notrunc), +! const_binop (MULT_EXPR, i1, i2, +! notrunc), +! notrunc), +! magsquared, notrunc), +! const_binop (INTEGRAL_TYPE_P (TREE_TYPE (r1)) +! ? TRUNC_DIV_EXPR : RDIV_EXPR, +! const_binop (MINUS_EXPR, +! const_binop (MULT_EXPR, i1, r2, +! notrunc), +! const_binop (MULT_EXPR, r1, i2, +! notrunc), +! notrunc), +! magsquared, notrunc)); + } + break; +--- 1278,1302 ---- + notrunc); + +! t = build_complex (type, +! const_binop +! (INTEGRAL_TYPE_P (TREE_TYPE (r1)) +! ? TRUNC_DIV_EXPR : RDIV_EXPR, +! const_binop (PLUS_EXPR, +! const_binop (MULT_EXPR, r1, r2, +! notrunc), +! const_binop (MULT_EXPR, i1, i2, +! notrunc), +! notrunc), +! magsquared, notrunc), +! const_binop +! (INTEGRAL_TYPE_P (TREE_TYPE (r1)) +! ? TRUNC_DIV_EXPR : RDIV_EXPR, +! const_binop (MINUS_EXPR, +! const_binop (MULT_EXPR, i1, r2, +! notrunc), +! const_binop (MULT_EXPR, r1, i2, +! notrunc), +! notrunc), +! magsquared, notrunc)); + } + break; +*************** const_binop (code, arg1, arg2, notrunc) +*** 1296,1300 **** + abort (); + } +- TREE_TYPE (t) = TREE_TYPE (arg1); + return t; + } +--- 1305,1308 ---- +*************** size_binop (code, arg0, arg1) +*** 1346,1363 **** + { + /* And some specific cases even faster than that. */ +! if (code == PLUS_EXPR +! && TREE_INT_CST_LOW (arg0) == 0 +! && TREE_INT_CST_HIGH (arg0) == 0) + return arg1; +! if (code == MINUS_EXPR +! && TREE_INT_CST_LOW (arg1) == 0 +! && TREE_INT_CST_HIGH (arg1) == 0) + return arg0; +! if (code == MULT_EXPR +! && TREE_INT_CST_LOW (arg0) == 1 +! && TREE_INT_CST_HIGH (arg0) == 0) + return arg1; + /* Handle general case of two integer constants. */ +! return const_binop (code, arg0, arg1, 0); + } + +--- 1354,1367 ---- + { + /* And some specific cases even faster than that. */ +! if (code == PLUS_EXPR && integer_zerop (arg0)) + return arg1; +! else if ((code == MINUS_EXPR || code == PLUS_EXPR) +! && integer_zerop (arg1)) + return arg0; +! else if (code == MULT_EXPR && integer_onep (arg0)) + return arg1; ++ + /* Handle general case of two integer constants. */ +! return const_binop (code, arg0, arg1, 1); + } + +*************** fold_convert (t, arg1) +*** 1482,1486 **** + { + if (REAL_VALUE_ISNAN (TREE_REAL_CST (arg1))) +! return arg1; + else if (setjmp (float_error)) + { +--- 1486,1494 ---- + { + if (REAL_VALUE_ISNAN (TREE_REAL_CST (arg1))) +! { +! t = arg1; +! TREE_TYPE (arg1) = type; +! return t; +! } + else if (setjmp (float_error)) + { +*************** operand_equal_p (arg0, arg1, only_const) +*** 1644,1687 **** + STRIP_NOPS (arg1); + +! /* If ARG0 and ARG1 are the same SAVE_EXPR, they are necessarily equal. +! We don't care about side effects in that case because the SAVE_EXPR +! takes care of that for us. */ +! if (TREE_CODE (arg0) == SAVE_EXPR && arg0 == arg1) +! return ! only_const; +! +! if (TREE_SIDE_EFFECTS (arg0) || TREE_SIDE_EFFECTS (arg1)) + return 0; + +! if (TREE_CODE (arg0) == TREE_CODE (arg1) +! && TREE_CODE (arg0) == ADDR_EXPR +! && TREE_OPERAND (arg0, 0) == TREE_OPERAND (arg1, 0)) +! return 1; +! +! if (TREE_CODE (arg0) == TREE_CODE (arg1) +! && TREE_CODE (arg0) == INTEGER_CST +! && TREE_INT_CST_LOW (arg0) == TREE_INT_CST_LOW (arg1) +! && TREE_INT_CST_HIGH (arg0) == TREE_INT_CST_HIGH (arg1)) + return 1; + +! /* Detect when real constants are equal. */ +! if (TREE_CODE (arg0) == TREE_CODE (arg1) +! && TREE_CODE (arg0) == REAL_CST) +! return !bcmp ((char *) &TREE_REAL_CST (arg0), +! (char *) &TREE_REAL_CST (arg1), +! sizeof (REAL_VALUE_TYPE)); + + if (only_const) + return 0; + +- if (arg0 == arg1) +- return 1; +- +- if (TREE_CODE (arg0) != TREE_CODE (arg1)) +- return 0; +- /* This is needed for conversions and for COMPONENT_REF. +- Might as well play it safe and always test this. */ +- if (TYPE_MODE (TREE_TYPE (arg0)) != TYPE_MODE (TREE_TYPE (arg1))) +- return 0; +- + switch (TREE_CODE_CLASS (TREE_CODE (arg0))) + { +--- 1652,1705 ---- + STRIP_NOPS (arg1); + +! if (TREE_CODE (arg0) != TREE_CODE (arg1) +! /* This is needed for conversions and for COMPONENT_REF. +! Might as well play it safe and always test this. */ +! || TYPE_MODE (TREE_TYPE (arg0)) != TYPE_MODE (TREE_TYPE (arg1))) + return 0; + +! /* If ARG0 and ARG1 are the same SAVE_EXPR, they are necessarily equal. +! We don't care about side effects in that case because the SAVE_EXPR +! takes care of that for us. In all other cases, two expressions are +! equal if they have no side effects. If we have two identical +! expressions with side effects that should be treated the same due +! to the only side effects being identical SAVE_EXPR's, that will +! be detected in the recursive calls below. */ +! if (arg0 == arg1 && ! only_const +! && (TREE_CODE (arg0) == SAVE_EXPR +! || (! TREE_SIDE_EFFECTS (arg0) && ! TREE_SIDE_EFFECTS (arg1)))) + return 1; + +! /* Next handle constant cases, those for which we can return 1 even +! if ONLY_CONST is set. */ +! if (TREE_CONSTANT (arg0) && TREE_CONSTANT (arg1)) +! switch (TREE_CODE (arg0)) +! { +! case INTEGER_CST: +! return (TREE_INT_CST_LOW (arg0) == TREE_INT_CST_LOW (arg1) +! && TREE_INT_CST_HIGH (arg0) == TREE_INT_CST_HIGH (arg1)); +! +! case REAL_CST: +! return REAL_VALUES_EQUAL (TREE_REAL_CST (arg0), TREE_REAL_CST (arg1)); +! +! case COMPLEX_CST: +! return (operand_equal_p (TREE_REALPART (arg0), TREE_REALPART (arg1), +! only_const) +! && operand_equal_p (TREE_IMAGPART (arg0), TREE_IMAGPART (arg1), +! only_const)); +! +! case STRING_CST: +! return (TREE_STRING_LENGTH (arg0) == TREE_STRING_LENGTH (arg1) +! && ! strncmp (TREE_STRING_POINTER (arg0), +! TREE_STRING_POINTER (arg1), +! TREE_STRING_LENGTH (arg0))); +! +! case ADDR_EXPR: +! return operand_equal_p (TREE_OPERAND (arg0, 0), TREE_OPERAND (arg1, 0), +! 0); +! } + + if (only_const) + return 0; + + switch (TREE_CODE_CLASS (TREE_CODE (arg0))) + { +*************** operand_equal_p (arg0, arg1, only_const) +*** 1698,1705 **** + case '<': + case '2': +! return (operand_equal_p (TREE_OPERAND (arg0, 0), +! TREE_OPERAND (arg1, 0), 0) + && operand_equal_p (TREE_OPERAND (arg0, 1), +! TREE_OPERAND (arg1, 1), 0)); + + case 'r': +--- 1716,1735 ---- + case '<': + case '2': +! if (operand_equal_p (TREE_OPERAND (arg0, 0), TREE_OPERAND (arg1, 0), 0) +! && operand_equal_p (TREE_OPERAND (arg0, 1), TREE_OPERAND (arg1, 1), +! 0)) +! return 1; +! +! /* For commutative ops, allow the other order. */ +! return ((TREE_CODE (arg0) == PLUS_EXPR || TREE_CODE (arg0) == MULT_EXPR +! || TREE_CODE (arg0) == MIN_EXPR || TREE_CODE (arg0) == MAX_EXPR +! || TREE_CODE (arg0) == BIT_IOR_EXPR +! || TREE_CODE (arg0) == BIT_XOR_EXPR +! || TREE_CODE (arg0) == BIT_AND_EXPR +! || TREE_CODE (arg0) == NE_EXPR || TREE_CODE (arg0) == EQ_EXPR) +! && operand_equal_p (TREE_OPERAND (arg0, 0), +! TREE_OPERAND (arg1, 1), 0) + && operand_equal_p (TREE_OPERAND (arg0, 1), +! TREE_OPERAND (arg1, 0), 0)); + + case 'r': +*************** optimize_bit_field_compare (code, compar +*** 2212,2215 **** +--- 2242,2246 ---- + int lunsignedp, runsignedp; + int lvolatilep = 0, rvolatilep = 0; ++ int alignment; + tree linner, rinner; + tree mask; +*************** optimize_bit_field_compare (code, compar +*** 2220,2224 **** + extraction at all and so can do nothing. */ + linner = get_inner_reference (lhs, &lbitsize, &lbitpos, &offset, &lmode, +! &lunsignedp, &lvolatilep); + if (linner == lhs || lbitsize == GET_MODE_BITSIZE (lmode) || lbitsize < 0 + || offset != 0) +--- 2251,2255 ---- + extraction at all and so can do nothing. */ + linner = get_inner_reference (lhs, &lbitsize, &lbitpos, &offset, &lmode, +! &lunsignedp, &lvolatilep, &alignment); + if (linner == lhs || lbitsize == GET_MODE_BITSIZE (lmode) || lbitsize < 0 + || offset != 0) +*************** optimize_bit_field_compare (code, compar +*** 2229,2234 **** + /* If this is not a constant, we can only do something if bit positions, + sizes, and signedness are the same. */ +! rinner = get_inner_reference (rhs, &rbitsize, &rbitpos, &offset, +! &rmode, &runsignedp, &rvolatilep); + + if (rinner == rhs || lbitpos != rbitpos || lbitsize != rbitsize +--- 2260,2265 ---- + /* If this is not a constant, we can only do something if bit positions, + sizes, and signedness are the same. */ +! rinner = get_inner_reference (rhs, &rbitsize, &rbitpos, &offset, &rmode, +! &runsignedp, &rvolatilep, &alignment); + + if (rinner == rhs || lbitpos != rbitpos || lbitsize != rbitsize +*************** decode_field_reference (exp, pbitsize, p +*** 2403,2406 **** +--- 2434,2438 ---- + tree unsigned_type; + int precision; ++ int alignment; + + /* All the optimizations using this function assume integer fields. +*************** decode_field_reference (exp, pbitsize, p +*** 2423,2427 **** + + inner = get_inner_reference (exp, pbitsize, pbitpos, &offset, pmode, +! punsignedp, pvolatilep); + if ((inner == exp && and_mask == 0) + || *pbitsize < 0 || offset != 0) +--- 2455,2459 ---- + + inner = get_inner_reference (exp, pbitsize, pbitpos, &offset, pmode, +! punsignedp, pvolatilep, &alignment); + if ((inner == exp && and_mask == 0) + || *pbitsize < 0 || offset != 0) +*************** strip_compound_expr (t, s) +*** 3065,3068 **** +--- 3097,3200 ---- + } + ++ /* Determine if first argument is a multiple of second argument. ++ Return 0 if it is not, or is not easily determined to so be. ++ ++ An example of the sort of thing we care about (at this point -- ++ this routine could surely be made more general, and expanded ++ to do what the *_DIV_EXPR's fold() cases do now) is discovering ++ that ++ ++ SAVE_EXPR (I) * SAVE_EXPR (J * 8) ++ ++ is a multiple of ++ ++ SAVE_EXPR (J * 8) ++ ++ when we know that the two `SAVE_EXPR (J * 8)' nodes are the ++ same node (which means they will have the same value at run ++ time, even though we don't know when they'll be assigned). ++ ++ This code also handles discovering that ++ ++ SAVE_EXPR (I) * SAVE_EXPR (J * 8) ++ ++ is a multiple of ++ ++ 8 ++ ++ (of course) so we don't have to worry about dealing with a ++ possible remainder. ++ ++ Note that we _look_ inside a SAVE_EXPR only to determine ++ how it was calculated; it is not safe for fold() to do much ++ of anything else with the internals of a SAVE_EXPR, since ++ fold() cannot know when it will be evaluated at run time. ++ For example, the latter example above _cannot_ be implemented ++ as ++ ++ SAVE_EXPR (I) * J ++ ++ or any variant thereof, since the value of J at evaluation time ++ of the original SAVE_EXPR is not necessarily the same at the time ++ the new expression is evaluated. The only optimization of this ++ sort that would be valid is changing ++ ++ SAVE_EXPR (I) * SAVE_EXPR (SAVE_EXPR (J) * 8) ++ divided by ++ 8 ++ ++ to ++ ++ SAVE_EXPR (I) * SAVE_EXPR (J) ++ ++ (where the same SAVE_EXPR (J) is used in the original and the ++ transformed version). */ ++ ++ static int ++ multiple_of_p (type, top, bottom) ++ tree type; ++ tree top; ++ tree bottom; ++ { ++ if (operand_equal_p (top, bottom, 0)) ++ return 1; ++ ++ if (TREE_CODE (type) != INTEGER_TYPE) ++ return 0; ++ ++ switch (TREE_CODE (top)) ++ { ++ case MULT_EXPR: ++ return (multiple_of_p (type, TREE_OPERAND (top, 0), bottom) ++ || multiple_of_p (type, TREE_OPERAND (top, 1), bottom)); ++ ++ case PLUS_EXPR: ++ case MINUS_EXPR: ++ return (multiple_of_p (type, TREE_OPERAND (top, 0), bottom) ++ && multiple_of_p (type, TREE_OPERAND (top, 1), bottom)); ++ ++ case NOP_EXPR: ++ /* Punt if conversion from non-integral or wider integral type. */ ++ if ((TREE_CODE (TREE_TYPE (TREE_OPERAND (top, 0))) != INTEGER_TYPE) ++ || (TYPE_PRECISION (type) ++ < TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (top, 0))))) ++ return 0; ++ /* Fall through. */ ++ case SAVE_EXPR: ++ return multiple_of_p (type, TREE_OPERAND (top, 0), bottom); ++ ++ case INTEGER_CST: ++ if ((TREE_CODE (bottom) != INTEGER_CST) ++ || (tree_int_cst_sgn (top) < 0) ++ || (tree_int_cst_sgn (bottom) < 0)) ++ return 0; ++ return integer_zerop (const_binop (TRUNC_MOD_EXPR, ++ top, bottom, 0)); ++ ++ default: ++ return 0; ++ } ++ } ++ + /* Perform constant folding and related simplification of EXPR. + The related simplifications include x*1 => x, x*0 => 0, etc., +*************** fold (expr) +*** 3611,3615 **** + TREE_OPERAND (arg0, 1)))); + else if (TREE_CODE (arg0) == COMPLEX_CST) +! return build_complex (TREE_OPERAND (arg0, 0), + fold (build1 (NEGATE_EXPR, + TREE_TYPE (TREE_TYPE (arg0)), +--- 3743,3747 ---- + TREE_OPERAND (arg0, 1)))); + else if (TREE_CODE (arg0) == COMPLEX_CST) +! return build_complex (type, TREE_OPERAND (arg0, 0), + fold (build1 (NEGATE_EXPR, + TREE_TYPE (TREE_TYPE (arg0)), +*************** fold (expr) +*** 4014,4018 **** + return non_lvalue (convert (type, arg0)); + if (integer_zerop (arg1)) +! return t; + + /* If we have ((a / C1) / C2) where both division are the same type, try +--- 4146,4166 ---- + return non_lvalue (convert (type, arg0)); + if (integer_zerop (arg1)) +! { +! if (extra_warnings) +! warning ("integer division by zero"); +! return t; +! } +! +! /* If arg0 is a multiple of arg1, then rewrite to the fastest div +! operation, EXACT_DIV_EXPR. Otherwise, handle folding of +! general divide. Note that only CEIL_DIV_EXPR is rewritten now, +! only because the others seem to be faster in some cases, e.g. the +! nonoptimized TRUNC_DIV_EXPR or FLOOR_DIV_EXPR on DEC Alpha. This +! is probably just due to more work being done on it in expmed.c than +! on EXACT_DIV_EXPR, and could presumably be fixed, since +! EXACT_DIV_EXPR should _never_ be slower than *_DIV_EXPR. */ +! if ((code == CEIL_DIV_EXPR) +! && multiple_of_p (type, arg0, arg1)) +! return fold (build (EXACT_DIV_EXPR, type, arg0, arg1)); + + /* If we have ((a / C1) / C2) where both division are the same type, try +*************** fold (expr) +*** 4049,4053 **** + tree xarg0 = arg0; + +! if (TREE_CODE (xarg0) == SAVE_EXPR) + have_save_expr = 1, xarg0 = TREE_OPERAND (xarg0, 0); + +--- 4197,4201 ---- + tree xarg0 = arg0; + +! if (TREE_CODE (xarg0) == SAVE_EXPR && SAVE_EXPR_RTL (xarg0) == 0) + have_save_expr = 1, xarg0 = TREE_OPERAND (xarg0, 0); + +*************** fold (expr) +*** 4067,4071 **** + } + +! if (TREE_CODE (xarg0) == SAVE_EXPR) + have_save_expr = 1, xarg0 = TREE_OPERAND (xarg0, 0); + +--- 4215,4219 ---- + } + +! if (TREE_CODE (xarg0) == SAVE_EXPR && SAVE_EXPR_RTL (xarg0) == 0) + have_save_expr = 1, xarg0 = TREE_OPERAND (xarg0, 0); + +*************** fold (expr) +*** 5050,5054 **** + case COMPLEX_EXPR: + if (wins) +! return build_complex (arg0, arg1); + return t; + +--- 5198,5202 ---- + case COMPLEX_EXPR: + if (wins) +! return build_complex (type, arg0, arg1); + return t; + +diff -rcp2N gcc-2.7.2.2/function.c g77-new/function.c +*** gcc-2.7.2.2/function.c Sun Nov 26 14:50:26 1995 +--- g77-new/function.c Sun Aug 10 18:47:24 1997 +*************** free_temps_for_rtl_expr (t) +*** 1184,1187 **** +--- 1184,1202 ---- + } + ++ /* Mark all temporaries ever allocated in this functon as not suitable ++ for reuse until the current level is exited. */ ++ ++ void ++ mark_all_temps_used () ++ { ++ struct temp_slot *p; ++ ++ for (p = temp_slots; p; p = p->next) ++ { ++ p->in_use = 1; ++ p->level = MIN (p->level, temp_slot_level); ++ } ++ } ++ + /* Push deeper into the nesting level for stack temporaries. */ + +*************** pop_temp_slots () +*** 1208,1211 **** +--- 1223,1237 ---- + temp_slot_level--; + } ++ ++ /* Initialize temporary slots. */ ++ ++ void ++ init_temp_slots () ++ { ++ /* We have not allocated any temporaries yet. */ ++ temp_slots = 0; ++ temp_slot_level = 0; ++ target_temp_slot_level = 0; ++ } + + /* Retroactively move an auto variable from a register to a stack slot. +*************** instantiate_virtual_regs_1 (loc, object, +*** 2838,2842 **** + case MEM: + /* Most cases of MEM that convert to valid addresses have already been +! handled by our scan of regno_reg_rtx. The only special handling we + need here is to make a copy of the rtx to ensure it isn't being + shared if we have to change it to a pseudo. +--- 2864,2868 ---- + case MEM: + /* Most cases of MEM that convert to valid addresses have already been +! handled by our scan of decls. The only special handling we + need here is to make a copy of the rtx to ensure it isn't being + shared if we have to change it to a pseudo. +*************** instantiate_virtual_regs_1 (loc, object, +*** 2896,2900 **** + has less restrictions on an address that some other insn. + In that case, we will modify the shared address. This case +! doesn't seem very likely, though. */ + + if (instantiate_virtual_regs_1 (&XEXP (x, 0), +--- 2922,2928 ---- + has less restrictions on an address that some other insn. + In that case, we will modify the shared address. This case +! doesn't seem very likely, though. One case where this could +! happen is in the case of a USE or CLOBBER reference, but we +! take care of that below. */ + + if (instantiate_virtual_regs_1 (&XEXP (x, 0), +*************** instantiate_virtual_regs_1 (loc, object, +*** 2909,2914 **** + + /* Fall through to generic unary operation case. */ +- case USE: +- case CLOBBER: + case SUBREG: + case STRICT_LOW_PART: +--- 2937,2940 ---- +*************** instantiate_virtual_regs_1 (loc, object, +*** 2927,2930 **** +--- 2953,2973 ---- + goto restart; + ++ case USE: ++ case CLOBBER: ++ /* If the operand is a MEM, see if the change is a valid MEM. If not, ++ go ahead and make the invalid one, but do it to a copy. For a REG, ++ just make the recursive call, since there's no chance of a problem. */ ++ ++ if ((GET_CODE (XEXP (x, 0)) == MEM ++ && instantiate_virtual_regs_1 (&XEXP (XEXP (x, 0), 0), XEXP (x, 0), ++ 0)) ++ || (GET_CODE (XEXP (x, 0)) == REG ++ && instantiate_virtual_regs_1 (&XEXP (x, 0), 0, 0))) ++ return 1; ++ ++ XEXP (x, 0) = copy_rtx (XEXP (x, 0)); ++ loc = &XEXP (x, 0); ++ goto restart; ++ + case REG: + /* Try to replace with a PLUS. If that doesn't work, compute the sum +*************** assign_parms (fndecl, second_time) +*** 3404,3409 **** + + /* If this is a memory ref that contains aggregate components, +! mark it as such for cse and loop optimize. */ + MEM_IN_STRUCT_P (stack_parm) = aggregate; + } + +--- 3447,3454 ---- + + /* If this is a memory ref that contains aggregate components, +! mark it as such for cse and loop optimize. Likewise if it +! is readonly. */ + MEM_IN_STRUCT_P (stack_parm) = aggregate; ++ RTX_UNCHANGING_P (stack_parm) = TREE_READONLY (parm); + } + +*************** assign_parms (fndecl, second_time) +*** 3627,3631 **** + + parmreg = gen_reg_rtx (promoted_nominal_mode); +! REG_USERVAR_P (parmreg) = 1; + + /* If this was an item that we received a pointer to, set DECL_RTL +--- 3672,3676 ---- + + parmreg = gen_reg_rtx (promoted_nominal_mode); +! mark_user_reg (parmreg); + + /* If this was an item that we received a pointer to, set DECL_RTL +*************** assign_parms (fndecl, second_time) +*** 3695,3699 **** + Pmode above. We must use the actual mode of the parm. */ + parmreg = gen_reg_rtx (TYPE_MODE (TREE_TYPE (parm))); +! REG_USERVAR_P (parmreg) = 1; + emit_move_insn (parmreg, DECL_RTL (parm)); + DECL_RTL (parm) = parmreg; +--- 3740,3744 ---- + Pmode above. We must use the actual mode of the parm. */ + parmreg = gen_reg_rtx (TYPE_MODE (TREE_TYPE (parm))); +! mark_user_reg (parmreg); + emit_move_insn (parmreg, DECL_RTL (parm)); + DECL_RTL (parm) = parmreg; +*************** init_function_start (subr, filename, lin +*** 4814,4821 **** + rtl_expr_chain = 0; + +! /* We have not allocated any temporaries yet. */ +! temp_slots = 0; +! temp_slot_level = 0; +! target_temp_slot_level = 0; + + /* Within function body, compute a type's size as soon it is laid out. */ +--- 4859,4864 ---- + rtl_expr_chain = 0; + +! /* Set up to allocate temporaries. */ +! init_temp_slots (); + + /* Within function body, compute a type's size as soon it is laid out. */ +diff -rcp2N gcc-2.7.2.2/gcc.c g77-new/gcc.c +*** gcc-2.7.2.2/gcc.c Tue Sep 12 17:15:11 1995 +--- g77-new/gcc.c Sun Aug 10 18:47:14 1997 +*************** static int is_directory PROTO((char *, +*** 296,300 **** + static void validate_switches PROTO((char *)); + static void validate_all_switches PROTO((void)); +! static void give_switch PROTO((int, int)); + static int used_arg PROTO((char *, int)); + static int default_arg PROTO((char *, int)); +--- 296,300 ---- + static void validate_switches PROTO((char *)); + static void validate_all_switches PROTO((void)); +! static void give_switch PROTO((int, int, int)); + static int used_arg PROTO((char *, int)); + static int default_arg PROTO((char *, int)); +*************** or with constant text in a single argume +*** 405,408 **** +--- 405,409 ---- + name starts with `o'. %{o*} would substitute this text, + including the space; thus, two arguments would be generated. ++ %{^S*} likewise, but don't put a blank between a switch and any args. + %{S*:X} substitutes X if one or more switches whose names start with -S are + specified to CC. Note that the tail part of the -S option +*************** process_command (argc, argv) +*** 2828,2831 **** +--- 2829,2835 ---- + infiles[n_infiles++].name = argv[i]; + } ++ /* -save-temps overrides -pipe, so that temp files are produced */ ++ else if (save_temps_flag && strcmp (argv[i], "-pipe") == 0) ++ ; + else if (argv[i][0] == '-' && argv[i][1] != 0) + { +*************** handle_braces (p) +*** 3832,3835 **** +--- 3836,3844 ---- + int negate = 0; + int suffix = 0; ++ int include_blanks = 1; ++ ++ if (*p == '^') ++ /* A '^' after the open-brace means to not give blanks before args. */ ++ include_blanks = 0, ++p; + + if (*p == '|') +*************** handle_braces (p) +*** 3897,3901 **** + if (!strncmp (switches[i].part1, filter, p - filter) + && check_live_switch (i, p - filter)) +! give_switch (i, 0); + } + else +--- 3906,3910 ---- + if (!strncmp (switches[i].part1, filter, p - filter) + && check_live_switch (i, p - filter)) +! give_switch (i, 0, include_blanks); + } + else +*************** handle_braces (p) +*** 3936,3940 **** + do_spec_1 (string, 0, &switches[i].part1[hard_match_len]); + /* Pass any arguments this switch has. */ +! give_switch (i, 1); + } + +--- 3945,3949 ---- + do_spec_1 (string, 0, &switches[i].part1[hard_match_len]); + /* Pass any arguments this switch has. */ +! give_switch (i, 1, 1); + } + +*************** handle_braces (p) +*** 3980,3984 **** + if (*p == '}') + { +! give_switch (i, 0); + } + else +--- 3989,3993 ---- + if (*p == '}') + { +! give_switch (i, 0, include_blanks); + } + else +*************** check_live_switch (switchnum, prefix_len +*** 4081,4090 **** + This cannot fail since it never finishes a command line. + +! If OMIT_FIRST_WORD is nonzero, then we omit .part1 of the argument. */ + + static void +! give_switch (switchnum, omit_first_word) + int switchnum; + int omit_first_word; + { + if (!omit_first_word) +--- 4090,4103 ---- + This cannot fail since it never finishes a command line. + +! If OMIT_FIRST_WORD is nonzero, then we omit .part1 of the argument. +! +! If INCLUDE_BLANKS is nonzero, then we include blanks before each argument +! of the switch. */ + + static void +! give_switch (switchnum, omit_first_word, include_blanks) + int switchnum; + int omit_first_word; ++ int include_blanks; + { + if (!omit_first_word) +*************** give_switch (switchnum, omit_first_word) +*** 4093,4097 **** + do_spec_1 (switches[switchnum].part1, 1, NULL_PTR); + } +! do_spec_1 (" ", 0, NULL_PTR); + if (switches[switchnum].args != 0) + { +--- 4106,4110 ---- + do_spec_1 (switches[switchnum].part1, 1, NULL_PTR); + } +! + if (switches[switchnum].args != 0) + { +*************** give_switch (switchnum, omit_first_word) +*** 4099,4106 **** + for (p = switches[switchnum].args; *p; p++) + { + do_spec_1 (*p, 1, NULL_PTR); +- do_spec_1 (" ", 0, NULL_PTR); + } + } + switches[switchnum].valid = 1; + } +--- 4112,4122 ---- + for (p = switches[switchnum].args; *p; p++) + { ++ if (include_blanks) ++ do_spec_1 (" ", 0, NULL_PTR); + do_spec_1 (*p, 1, NULL_PTR); + } + } ++ ++ do_spec_1 (" ", 0, NULL_PTR); + switches[switchnum].valid = 1; + } +diff -rcp2N gcc-2.7.2.2/gcc.texi g77-new/gcc.texi +*** gcc-2.7.2.2/gcc.texi Thu Feb 20 19:24:19 1997 +--- g77-new/gcc.texi Thu Jul 10 20:08:58 1997 +*************** original English. +*** 149,152 **** +--- 149,153 ---- + @sp 3 + @center Last updated 29 June 1996 ++ @center (Revised for GNU Fortran 1997-01-10) + @sp 1 + @c The version number appears twice more in this file. +diff -rcp2N gcc-2.7.2.2/glimits.h g77-new/glimits.h +*** gcc-2.7.2.2/glimits.h Wed Sep 29 17:30:54 1993 +--- g77-new/glimits.h Thu Jul 10 20:08:58 1997 +*************** +*** 64,68 **** + (Same as `int'). */ + #ifndef __LONG_MAX__ +! #define __LONG_MAX__ 2147483647L + #endif + #undef LONG_MIN +--- 64,72 ---- + (Same as `int'). */ + #ifndef __LONG_MAX__ +! # ifndef __alpha__ +! # define __LONG_MAX__ 2147483647L +! # else +! # define __LONG_MAX__ 9223372036854775807LL +! # endif /* __alpha__ */ + #endif + #undef LONG_MIN +diff -rcp2N gcc-2.7.2.2/integrate.c g77-new/integrate.c +*** gcc-2.7.2.2/integrate.c Fri Oct 20 18:48:13 1995 +--- g77-new/integrate.c Sun Aug 10 18:46:31 1997 +*************** static rtx copy_for_inline PROTO((rtx)); +*** 67,70 **** +--- 67,71 ---- + static void integrate_parm_decls PROTO((tree, struct inline_remap *, rtvec)); + static void integrate_decl_tree PROTO((tree, int, struct inline_remap *)); ++ static void save_constants_in_decl_trees PROTO ((tree)); + static void subst_constants PROTO((rtx *, rtx, struct inline_remap *)); + static void restore_constants PROTO((rtx *)); +*************** save_for_inline_copying (fndecl) +*** 435,438 **** +--- 436,443 ---- + } + ++ /* Also scan all decls, and replace any constant pool references with the ++ actual constant. */ ++ save_constants_in_decl_trees (DECL_INITIAL (fndecl)); ++ + /* Clear out the constant pool so that we can recreate it with the + copied constants below. */ +*************** save_for_inline_nocopy (fndecl) +*** 781,784 **** +--- 786,793 ---- + } + ++ /* Also scan all decls, and replace any constant pool references with the ++ actual constant. */ ++ save_constants_in_decl_trees (DECL_INITIAL (fndecl)); ++ + /* We have now allocated all that needs to be allocated permanently + on the rtx obstack. Set our high-water mark, so that we +*************** expand_inline_function (fndecl, parms, t +*** 1571,1575 **** + if (GET_CODE (XEXP (loc, 0)) == REG) + { +! temp = force_reg (Pmode, structure_value_addr); + map->reg_map[REGNO (XEXP (loc, 0))] = temp; + if ((CONSTANT_P (structure_value_addr) +--- 1580,1585 ---- + if (GET_CODE (XEXP (loc, 0)) == REG) + { +! temp = force_reg (Pmode, +! force_operand (structure_value_addr, NULL_RTX)); + map->reg_map[REGNO (XEXP (loc, 0))] = temp; + if ((CONSTANT_P (structure_value_addr) +*************** integrate_decl_tree (let, level, map) +*** 2029,2032 **** +--- 2039,2059 ---- + } + } ++ } ++ ++ /* Given a BLOCK node LET, search for all DECL_RTL fields, and pass them ++ through save_constants. */ ++ ++ static void ++ save_constants_in_decl_trees (let) ++ tree let; ++ { ++ tree t; ++ ++ for (t = BLOCK_VARS (let); t; t = TREE_CHAIN (t)) ++ if (DECL_RTL (t) != 0) ++ save_constants (&DECL_RTL (t)); ++ ++ for (t = BLOCK_SUBBLOCKS (let); t; t = TREE_CHAIN (t)) ++ save_constants_in_decl_trees (t); + } + +diff -rcp2N gcc-2.7.2.2/invoke.texi g77-new/invoke.texi +*** gcc-2.7.2.2/invoke.texi Tue Oct 3 11:40:43 1995 +--- g77-new/invoke.texi Thu Jul 10 20:09:00 1997 +*************** +*** 1,3 **** +! @c Copyright (C) 1988, 89, 92, 93, 94, 1995 Free Software Foundation, Inc. + @c This is part of the GCC manual. + @c For copying conditions, see the file gcc.texi. +--- 1,3 ---- +! @c Copyright (C) 1988, 89, 92-95, 1997 Free Software Foundation, Inc. + @c This is part of the GCC manual. + @c For copying conditions, see the file gcc.texi. +*************** in the following sections. +*** 149,152 **** +--- 149,153 ---- + -fschedule-insns2 -fstrength-reduce -fthread-jumps + -funroll-all-loops -funroll-loops ++ -fmove-all-movables -freduce-all-givs -frerun-loop-opt + -O -O0 -O1 -O2 -O3 + @end smallexample +*************** in addition to the above: +*** 331,334 **** +--- 332,337 ---- + -fshort-double -fvolatile -fvolatile-global + -fverbose-asm -fpack-struct +e0 +e1 ++ -fargument-alias -fargument-noalias ++ -fargument-noalias-global + @end smallexample + @end table +*************** Print extra warning messages for these e +*** 1253,1256 **** +--- 1256,1304 ---- + + @itemize @bullet ++ @cindex division by zero ++ @cindex zero, division by ++ @item ++ An integer division by zero is detected. ++ ++ Some cases of division by zero might occur as the result ++ of using so-called ``safe'' macros. ++ For example: ++ ++ @smallexample ++ #define BUCKETS(b) (((b) != NULL) ? (b)->buckets : 0) ++ @dots{...} ++ i = j / BUCKETS(b); ++ @end smallexample ++ ++ Although analysis of the context of the above code could ++ prove that @samp{b} is never null when it is executed, ++ the division-by-zero warning is still useful, because ++ @code{gcc} generates code to do the division by zero at ++ run time so as to generate a run-time fault, ++ and tidy programmers will want to find ways to prevent ++ this needless code from being generated. ++ ++ Note that @code{gcc} transforms expressions so as to find ++ opportunities for performing expensive operations ++ (such as division) at compile time instead of generating ++ code to perform them at run time. ++ For example, @code{gcc} transforms: ++ ++ @smallexample ++ 2 / (i == 0) ++ @end smallexample ++ ++ into: ++ ++ @smallexample ++ (i == 0) ? (2 / 1) : (2 / 0) ++ @end smallexample ++ ++ As a result, the division-by-zero warning might occur ++ in contexts where the divisor seems to be a non-constant. ++ It is useful in this case as well, because programmers might want ++ to clean up the code so the compiled code does not include ++ dead code to divide by zero. ++ + @cindex @code{longjmp} warnings + @item +*************** and usually makes programs run more slow +*** 1941,1944 **** +--- 1989,2037 ---- + implies @samp{-fstrength-reduce} as well as @samp{-frerun-cse-after-loop}. + ++ @item -fmove-all-movables ++ Forces all invariant computations in loops to be moved ++ outside the loop. ++ This option is provided primarily to improve performance ++ for some Fortran code, though it might improve code written ++ in other languages. ++ ++ @emph{Note:} When compiling programs written in Fortran, ++ this option is enabled by default. ++ ++ Analysis of Fortran code optimization and the resulting ++ optimizations triggered by this option, and the ++ @samp{-freduce-all-givs} and @samp{-frerun-loop-opt} ++ options as well, were ++ contributed by Toon Moene (@code{toon@@moene.indiv.nluug.nl}). ++ ++ These three options are intended to be removed someday, once ++ they have helped determine the efficacy of various ++ approaches to improving the performance of Fortran code. ++ ++ Please let us (@code{fortran@@gnu.ai.mit.edu}) ++ know how use of these options affects ++ the performance of your production code. ++ We're very interested in code that runs @emph{slower} ++ when these options are @emph{enabled}. ++ ++ @item -freduce-all-givs ++ Forces all general-induction variables in loops to be ++ strength-reduced. ++ This option is provided primarily to improve performance ++ for some Fortran code, though it might improve code written ++ in other languages. ++ ++ @emph{Note:} When compiling programs written in Fortran, ++ this option is enabled by default. ++ ++ @item -frerun-loop-opt ++ Runs loop optimizations a second time. ++ This option is provided primarily to improve performance ++ for some Fortran code, though it might improve code written ++ in other languages. ++ ++ @emph{Note:} When compiling programs written in Fortran, ++ this option is enabled by default. ++ + @item -fno-peephole + Disable any machine-specific peephole optimizations. +*************** compilation). +*** 4229,4232 **** +--- 4322,4397 ---- + With @samp{+e1}, G++ actually generates the code implementing virtual + functions defined in the code, and makes them publicly visible. ++ ++ @cindex aliasing of parameters ++ @cindex parameters, aliased ++ @item -fargument-alias ++ @item -fargument-noalias ++ @item -fargument-noalias-global ++ Specify the possible relationships among parameters and between ++ parameters and global data. ++ ++ @samp{-fargument-alias} specifies that arguments (parameters) may ++ alias each other and may alias global storage. ++ @samp{-fargument-noalias} specifies that arguments do not alias ++ each other, but may alias global storage. ++ @samp{-fargument-noalias-global} specifies that arguments do not ++ alias each other and do not alias global storage. ++ ++ For code written in C, C++, and Objective-C, @samp{-fargument-alias} ++ is the default. ++ For code written in Fortran, @samp{-fargument-noalias-global} is ++ the default, though this is pertinent only on systems where ++ @code{g77} is installed. ++ (See the documentation for other compilers for information on the ++ defaults for their respective languages.) ++ ++ Normally, @code{gcc} assumes that a write through a pointer ++ passed as a parameter to the current function might modify a ++ value pointed to by another pointer passed as a parameter, or ++ in global storage. ++ ++ For example, consider this code: ++ ++ @example ++ void x(int *i, int *j) ++ @{ ++ extern int k; ++ ++ ++*i; ++ ++*j; ++ ++k; ++ @} ++ @end example ++ ++ When compiling the above function, @code{gcc} assumes that @samp{i} might ++ be a pointer to the same variable as @samp{j}, and that either @samp{i}, ++ @samp{j}, or both might be a pointer to @samp{k}. ++ ++ Therefore, @code{gcc} does not assume it can generate code to read ++ @samp{*i}, @samp{*j}, and @samp{k} into separate registers, increment ++ each register, then write the incremented values back out. ++ ++ Instead, @code{gcc} must generate code that reads @samp{*i}, ++ increments it, and writes it back before reading @samp{*j}, ++ in case @samp{i} and @samp{j} are aliased, and, similarly, ++ that writes @samp{*j} before reading @samp{k}. ++ The result is code that, on many systems, takes longer to execute, ++ due to the way many processors schedule instruction execution. ++ ++ Compiling the above code with the @samp{-fargument-noalias} option ++ allows @code{gcc} to assume that @samp{i} and @samp{j} do not alias ++ each other, but either might alias @samp{k}. ++ ++ Compiling the above code with the @samp{-fargument-noalias-global} ++ option allows @code{gcc} to assume that no combination of @samp{i}, ++ @samp{j}, and @samp{k} are aliases for each other. ++ ++ @emph{Note:} Use the @samp{-fargument-noalias} and ++ @samp{-fargument-noalias-global} options with care. ++ While they can result in faster executables, they can ++ also result in executables with subtle bugs, bugs that ++ show up only when compiled for specific target systems, ++ or bugs that show up only when compiled by specific versions ++ of @code{g77}. + @end table + +diff -rcp2N gcc-2.7.2.2/libgcc2.c g77-new/libgcc2.c +*** gcc-2.7.2.2/libgcc2.c Sun Nov 26 14:39:21 1995 +--- g77-new/libgcc2.c Sun Aug 10 18:46:07 1997 +*************** __gcc_bcmp (s1, s2, size) +*** 1193,1196 **** +--- 1193,1201 ---- + #endif + ++ #ifdef L__dummy ++ void ++ __dummy () {} ++ #endif ++ + #ifdef L_varargs + #ifdef __i860__ +diff -rcp2N gcc-2.7.2.2/local-alloc.c g77-new/local-alloc.c +*** gcc-2.7.2.2/local-alloc.c Mon Aug 21 13:15:44 1995 +--- g77-new/local-alloc.c Sun Aug 10 18:46:10 1997 +*************** static int this_insn_number; +*** 243,246 **** +--- 243,250 ---- + static rtx this_insn; + ++ /* Used to communicate changes made by update_equiv_regs to ++ memref_referenced_p. */ ++ static rtx *reg_equiv_replacement; ++ + static void alloc_qty PROTO((int, enum machine_mode, int, int)); + static void alloc_qty_for_scratch PROTO((rtx, int, rtx, int, int)); +*************** validate_equiv_mem_from_store (dest, set +*** 545,549 **** + && reg_overlap_mentioned_p (dest, equiv_mem)) + || (GET_CODE (dest) == MEM +! && true_dependence (dest, equiv_mem))) + equiv_mem_modified = 1; + } +--- 549,553 ---- + && reg_overlap_mentioned_p (dest, equiv_mem)) + || (GET_CODE (dest) == MEM +! && true_dependence (dest, VOIDmode, equiv_mem, rtx_varies_p))) + equiv_mem_modified = 1; + } +*************** memref_referenced_p (memref, x) +*** 617,621 **** + switch (code) + { +- case REG: + case CONST_INT: + case CONST: +--- 621,624 ---- +*************** memref_referenced_p (memref, x) +*** 629,634 **** + return 0; + + case MEM: +! if (true_dependence (memref, x)) + return 1; + break; +--- 632,642 ---- + return 0; + ++ case REG: ++ return (reg_equiv_replacement[REGNO (x)] == 0 ++ || memref_referenced_p (memref, ++ reg_equiv_replacement[REGNO (x)])); ++ + case MEM: +! if (true_dependence (memref, VOIDmode, x, rtx_varies_p)) + return 1; + break; +*************** optimize_reg_copy_1 (insn, dest, src) +*** 818,827 **** + if (sregno >= FIRST_PSEUDO_REGISTER) + { +! reg_live_length[sregno] -= length; +! /* reg_live_length is only an approximation after combine +! if sched is not run, so make sure that we still have +! a reasonable value. */ +! if (reg_live_length[sregno] < 2) +! reg_live_length[sregno] = 2; + reg_n_calls_crossed[sregno] -= n_calls; + } +--- 826,839 ---- + if (sregno >= FIRST_PSEUDO_REGISTER) + { +! if (reg_live_length[sregno] >= 0) +! { +! reg_live_length[sregno] -= length; +! /* reg_live_length is only an approximation after +! combine if sched is not run, so make sure that we +! still have a reasonable value. */ +! if (reg_live_length[sregno] < 2) +! reg_live_length[sregno] = 2; +! } +! + reg_n_calls_crossed[sregno] -= n_calls; + } +*************** optimize_reg_copy_1 (insn, dest, src) +*** 829,833 **** + if (dregno >= FIRST_PSEUDO_REGISTER) + { +! reg_live_length[dregno] += d_length; + reg_n_calls_crossed[dregno] += d_n_calls; + } +--- 841,847 ---- + if (dregno >= FIRST_PSEUDO_REGISTER) + { +! if (reg_live_length[dregno] >= 0) +! reg_live_length[dregno] += d_length; +! + reg_n_calls_crossed[dregno] += d_n_calls; + } +*************** update_equiv_regs () +*** 948,953 **** + { + rtx *reg_equiv_init_insn = (rtx *) alloca (max_regno * sizeof (rtx *)); +- rtx *reg_equiv_replacement = (rtx *) alloca (max_regno * sizeof (rtx *)); + rtx insn; + + bzero ((char *) reg_equiv_init_insn, max_regno * sizeof (rtx *)); +--- 962,968 ---- + { + rtx *reg_equiv_init_insn = (rtx *) alloca (max_regno * sizeof (rtx *)); + rtx insn; ++ ++ reg_equiv_replacement = (rtx *) alloca (max_regno * sizeof (rtx *)); + + bzero ((char *) reg_equiv_init_insn, max_regno * sizeof (rtx *)); +diff -rcp2N gcc-2.7.2.2/loop.c g77-new/loop.c +*** gcc-2.7.2.2/loop.c Thu Feb 20 19:24:20 1997 +--- g77-new/loop.c Sun Aug 10 18:46:43 1997 +*************** int *loop_number_exit_count; +*** 111,116 **** + unsigned HOST_WIDE_INT loop_n_iterations; + +! /* Nonzero if there is a subroutine call in the current loop. +! (unknown_address_altered is also nonzero in this case.) */ + + static int loop_has_call; +--- 111,115 ---- + unsigned HOST_WIDE_INT loop_n_iterations; + +! /* Nonzero if there is a subroutine call in the current loop. */ + + static int loop_has_call; +*************** static char *moved_once; +*** 160,164 **** + here, we just turn on unknown_address_altered. */ + +! #define NUM_STORES 20 + static rtx loop_store_mems[NUM_STORES]; + +--- 159,163 ---- + here, we just turn on unknown_address_altered. */ + +! #define NUM_STORES 30 + static rtx loop_store_mems[NUM_STORES]; + +*************** scan_loop (loop_start, end, nregs) +*** 669,673 **** + { + temp = find_reg_note (p, REG_EQUAL, NULL_RTX); +! if (temp && CONSTANT_P (XEXP (temp, 0))) + src = XEXP (temp, 0), move_insn = 1; + if (temp && find_reg_note (p, REG_RETVAL, NULL_RTX)) +--- 668,673 ---- + { + temp = find_reg_note (p, REG_EQUAL, NULL_RTX); +! if (temp && CONSTANT_P (XEXP (temp, 0)) +! && LEGITIMATE_CONSTANT_P (XEXP (temp, 0))) + src = XEXP (temp, 0), move_insn = 1; + if (temp && find_reg_note (p, REG_RETVAL, NULL_RTX)) +*************** move_movables (movables, threshold, insn +*** 1629,1632 **** +--- 1629,1633 ---- + + if (already_moved[regno] ++ || flag_move_all_movables + || (threshold * savings * m->lifetime) >= insn_count + || (m->forces && m->forces->done +*************** prescan_loop (start, end) +*** 2199,2203 **** + else if (GET_CODE (insn) == CALL_INSN) + { +! unknown_address_altered = 1; + loop_has_call = 1; + } +--- 2200,2205 ---- + else if (GET_CODE (insn) == CALL_INSN) + { +! if (! CONST_CALL_P (insn)) +! unknown_address_altered = 1; + loop_has_call = 1; + } +*************** invariant_p (x) +*** 2777,2781 **** + /* See if there is any dependence between a store and this load. */ + for (i = loop_store_mems_idx - 1; i >= 0; i--) +! if (true_dependence (loop_store_mems[i], x)) + return 0; + +--- 2779,2783 ---- + /* See if there is any dependence between a store and this load. */ + for (i = loop_store_mems_idx - 1; i >= 0; i--) +! if (true_dependence (loop_store_mems[i], VOIDmode, x, rtx_varies_p)) + return 0; + +*************** strength_reduce (scan_start, end, loop_t +*** 3821,3826 **** + exit. */ + +! if (v->lifetime * threshold * benefit < insn_count +! && ! bl->reversed) + { + if (loop_dump_stream) +--- 3823,3828 ---- + exit. */ + +! if ( ! flag_reduce_all_givs && v->lifetime * threshold * benefit < insn_count +! && ! bl->reversed ) + { + if (loop_dump_stream) +*************** record_giv (v, insn, src_reg, dest_reg, +*** 4375,4378 **** +--- 4377,4382 ---- + v->final_value = 0; + v->same_insn = 0; ++ v->unrolled = 0; ++ v->shared = 0; + + /* The v->always_computable field is used in update_giv_derive, to +*************** check_final_value (v, loop_start, loop_e +*** 4652,4657 **** + if (GET_CODE (p) == JUMP_INSN && JUMP_LABEL (p) + && LABEL_NAME (JUMP_LABEL (p)) +! && ((INSN_LUID (JUMP_LABEL (p)) < INSN_LUID (v->insn) +! && INSN_LUID (JUMP_LABEL (p)) > INSN_LUID (loop_start)) + || (INSN_LUID (JUMP_LABEL (p)) > INSN_LUID (last_giv_use) + && INSN_LUID (JUMP_LABEL (p)) < INSN_LUID (loop_end)))) +--- 4656,4664 ---- + if (GET_CODE (p) == JUMP_INSN && JUMP_LABEL (p) + && LABEL_NAME (JUMP_LABEL (p)) +! && ((INSN_UID (JUMP_LABEL (p)) >= max_uid_for_loop) +! || (INSN_UID (v->insn) >= max_uid_for_loop) +! || (INSN_UID (last_giv_use) >= max_uid_for_loop) +! || (INSN_LUID (JUMP_LABEL (p)) < INSN_LUID (v->insn) +! && INSN_LUID (JUMP_LABEL (p)) > INSN_LUID (loop_start)) + || (INSN_LUID (JUMP_LABEL (p)) > INSN_LUID (last_giv_use) + && INSN_LUID (JUMP_LABEL (p)) < INSN_LUID (loop_end)))) +*************** emit_iv_add_mult (b, m, a, reg, insert_b +*** 5560,5563 **** +--- 5567,5572 ---- + + emit_insn_before (seq, insert_before); ++ ++ record_base_value (REGNO (reg), b); + } + +diff -rcp2N gcc-2.7.2.2/loop.h g77-new/loop.h +*** gcc-2.7.2.2/loop.h Fri Jul 14 08:23:28 1995 +--- g77-new/loop.h Thu Jul 10 20:09:03 1997 +*************** struct induction +*** 89,92 **** +--- 89,95 ---- + we won't use it to eliminate a biv, it + would probably lose. */ ++ unsigned unrolled : 1; /* 1 if new register has been allocated in ++ unrolled loop. */ ++ unsigned shared : 1; + int lifetime; /* Length of life of this giv */ + int times_used; /* # times this giv is used. */ +diff -rcp2N gcc-2.7.2.2/real.c g77-new/real.c +*** gcc-2.7.2.2/real.c Tue Aug 15 17:57:18 1995 +--- g77-new/real.c Thu Jul 10 20:09:04 1997 +*************** make_nan (nan, sign, mode) +*** 5625,5633 **** + } + +! /* Convert an SFmode target `float' value to a REAL_VALUE_TYPE. +! This is the inverse of the function `etarsingle' invoked by + REAL_VALUE_TO_TARGET_SINGLE. */ + + REAL_VALUE_TYPE + ereal_from_float (f) + HOST_WIDE_INT f; +--- 5625,5699 ---- + } + +! /* This is the inverse of the function `etarsingle' invoked by + REAL_VALUE_TO_TARGET_SINGLE. */ + + REAL_VALUE_TYPE ++ ereal_unto_float (f) ++ long f; ++ { ++ REAL_VALUE_TYPE r; ++ unsigned EMUSHORT s[2]; ++ unsigned EMUSHORT e[NE]; ++ ++ /* Convert 32 bit integer to array of 16 bit pieces in target machine order. ++ This is the inverse operation to what the function `endian' does. */ ++ if (REAL_WORDS_BIG_ENDIAN) ++ { ++ s[0] = (unsigned EMUSHORT) (f >> 16); ++ s[1] = (unsigned EMUSHORT) f; ++ } ++ else ++ { ++ s[0] = (unsigned EMUSHORT) f; ++ s[1] = (unsigned EMUSHORT) (f >> 16); ++ } ++ /* Convert and promote the target float to E-type. */ ++ e24toe (s, e); ++ /* Output E-type to REAL_VALUE_TYPE. */ ++ PUT_REAL (e, &r); ++ return r; ++ } ++ ++ ++ /* This is the inverse of the function `etardouble' invoked by ++ REAL_VALUE_TO_TARGET_DOUBLE. */ ++ ++ REAL_VALUE_TYPE ++ ereal_unto_double (d) ++ long d[]; ++ { ++ REAL_VALUE_TYPE r; ++ unsigned EMUSHORT s[4]; ++ unsigned EMUSHORT e[NE]; ++ ++ /* Convert array of HOST_WIDE_INT to equivalent array of 16-bit pieces. */ ++ if (REAL_WORDS_BIG_ENDIAN) ++ { ++ s[0] = (unsigned EMUSHORT) (d[0] >> 16); ++ s[1] = (unsigned EMUSHORT) d[0]; ++ s[2] = (unsigned EMUSHORT) (d[1] >> 16); ++ s[3] = (unsigned EMUSHORT) d[1]; ++ } ++ else ++ { ++ /* Target float words are little-endian. */ ++ s[0] = (unsigned EMUSHORT) d[0]; ++ s[1] = (unsigned EMUSHORT) (d[0] >> 16); ++ s[2] = (unsigned EMUSHORT) d[1]; ++ s[3] = (unsigned EMUSHORT) (d[1] >> 16); ++ } ++ /* Convert target double to E-type. */ ++ e53toe (s, e); ++ /* Output E-type to REAL_VALUE_TYPE. */ ++ PUT_REAL (e, &r); ++ return r; ++ } ++ ++ ++ /* Convert an SFmode target `float' value to a REAL_VALUE_TYPE. ++ This is somewhat like ereal_unto_float, but the input types ++ for these are different. */ ++ ++ REAL_VALUE_TYPE + ereal_from_float (f) + HOST_WIDE_INT f; +*************** ereal_from_float (f) +*** 5658,5663 **** + + /* Convert a DFmode target `double' value to a REAL_VALUE_TYPE. +! This is the inverse of the function `etardouble' invoked by +! REAL_VALUE_TO_TARGET_DOUBLE. + + The DFmode is stored as an array of HOST_WIDE_INT in the target's +--- 5724,5729 ---- + + /* Convert a DFmode target `double' value to a REAL_VALUE_TYPE. +! This is somewhat like ereal_unto_double, but the input types +! for these are different. + + The DFmode is stored as an array of HOST_WIDE_INT in the target's +diff -rcp2N gcc-2.7.2.2/real.h g77-new/real.h +*** gcc-2.7.2.2/real.h Thu Jun 15 07:57:56 1995 +--- g77-new/real.h Thu Jul 10 20:09:05 1997 +*************** extern void ereal_to_decimal PROTO((REAL +*** 152,155 **** +--- 152,157 ---- + extern int ereal_cmp PROTO((REAL_VALUE_TYPE, REAL_VALUE_TYPE)); + extern int ereal_isneg PROTO((REAL_VALUE_TYPE)); ++ extern REAL_VALUE_TYPE ereal_unto_float PROTO((long)); ++ extern REAL_VALUE_TYPE ereal_unto_double PROTO((long *)); + extern REAL_VALUE_TYPE ereal_from_float PROTO((HOST_WIDE_INT)); + extern REAL_VALUE_TYPE ereal_from_double PROTO((HOST_WIDE_INT *)); +*************** extern REAL_VALUE_TYPE real_value_trunca +*** 197,200 **** +--- 199,208 ---- + /* IN is a REAL_VALUE_TYPE. OUT is a long. */ + #define REAL_VALUE_TO_TARGET_SINGLE(IN, OUT) ((OUT) = etarsingle ((IN))) ++ ++ /* Inverse of REAL_VALUE_TO_TARGET_DOUBLE. */ ++ #define REAL_VALUE_UNTO_TARGET_DOUBLE(d) (ereal_unto_double (d)) ++ ++ /* Inverse of REAL_VALUE_TO_TARGET_SINGLE. */ ++ #define REAL_VALUE_UNTO_TARGET_SINGLE(f) (ereal_unto_float (f)) + + /* d is an array of HOST_WIDE_INT that holds a double precision +diff -rcp2N gcc-2.7.2.2/recog.c g77-new/recog.c +*** gcc-2.7.2.2/recog.c Sat Jul 1 06:52:35 1995 +--- g77-new/recog.c Sun Aug 10 18:46:55 1997 +*************** register_operand (op, mode) +*** 872,876 **** + REGNO (SUBREG_REG (op))) + && (GET_MODE_SIZE (mode) +! != GET_MODE_SIZE (GET_MODE (SUBREG_REG (op))))) + return 0; + #endif +--- 872,878 ---- + REGNO (SUBREG_REG (op))) + && (GET_MODE_SIZE (mode) +! != GET_MODE_SIZE (GET_MODE (SUBREG_REG (op)))) +! && GET_MODE_CLASS (GET_MODE (SUBREG_REG (op))) != MODE_COMPLEX_INT +! && GET_MODE_CLASS (GET_MODE (SUBREG_REG (op))) != MODE_COMPLEX_FLOAT) + return 0; + #endif +diff -rcp2N gcc-2.7.2.2/reload.c g77-new/reload.c +*** gcc-2.7.2.2/reload.c Sat Nov 11 08:23:54 1995 +--- g77-new/reload.c Sun Aug 10 04:58:03 1997 +*************** +*** 1,4 **** + /* Search an insn for pseudo regs that must be in hard regs and are not. +! Copyright (C) 1987, 88, 89, 92, 93, 94, 1995 Free Software Foundation, Inc. + + This file is part of GNU CC. +--- 1,4 ---- + /* Search an insn for pseudo regs that must be in hard regs and are not. +! Copyright (C) 1987, 88, 89, 92-5, 1996 Free Software Foundation, Inc. + + This file is part of GNU CC. +*************** static int push_secondary_reload PROTO(( +*** 292,295 **** +--- 292,296 ---- + enum machine_mode, enum reload_type, + enum insn_code *)); ++ static enum reg_class find_valid_class PROTO((enum machine_mode, int)); + static int push_reload PROTO((rtx, rtx, rtx *, rtx *, enum reg_class, + enum machine_mode, enum machine_mode, +*************** static struct decomposition decompose PR +*** 305,312 **** + static int immune_p PROTO((rtx, rtx, struct decomposition)); + static int alternative_allows_memconst PROTO((char *, int)); +! static rtx find_reloads_toplev PROTO((rtx, int, enum reload_type, int, int)); + static rtx make_memloc PROTO((rtx, int)); + static int find_reloads_address PROTO((enum machine_mode, rtx *, rtx, rtx *, +! int, enum reload_type, int)); + static rtx subst_reg_equivs PROTO((rtx)); + static rtx subst_indexed_address PROTO((rtx)); +--- 306,313 ---- + static int immune_p PROTO((rtx, rtx, struct decomposition)); + static int alternative_allows_memconst PROTO((char *, int)); +! static rtx find_reloads_toplev PROTO((rtx, int, enum reload_type, int, int, short *)); + static rtx make_memloc PROTO((rtx, int)); + static int find_reloads_address PROTO((enum machine_mode, rtx *, rtx, rtx *, +! int, enum reload_type, int, short *)); + static rtx subst_reg_equivs PROTO((rtx)); + static rtx subst_indexed_address PROTO((rtx)); +*************** push_secondary_reload (in_p, x, opnum, o +*** 590,599 **** + + if (in_p && icode == CODE_FOR_nothing +! && SECONDARY_MEMORY_NEEDED (class, reload_class, reload_mode)) +! get_secondary_mem (x, reload_mode, opnum, type); + + if (! in_p && icode == CODE_FOR_nothing +! && SECONDARY_MEMORY_NEEDED (reload_class, class, reload_mode)) +! get_secondary_mem (x, reload_mode, opnum, type); + #endif + } +--- 591,600 ---- + + if (in_p && icode == CODE_FOR_nothing +! && SECONDARY_MEMORY_NEEDED (class, reload_class, mode)) +! get_secondary_mem (x, mode, opnum, type); + + if (! in_p && icode == CODE_FOR_nothing +! && SECONDARY_MEMORY_NEEDED (reload_class, class, mode)) +! get_secondary_mem (x, mode, opnum, type); + #endif + } +*************** get_secondary_mem (x, mode, opnum, type) +*** 673,677 **** + + find_reloads_address (mode, NULL_PTR, XEXP (loc, 0), &XEXP (loc, 0), +! opnum, type, 0); + } + +--- 674,678 ---- + + find_reloads_address (mode, NULL_PTR, XEXP (loc, 0), &XEXP (loc, 0), +! opnum, type, 0, NULL); + } + +*************** clear_secondary_mem () +*** 689,692 **** +--- 690,725 ---- + #endif /* SECONDARY_MEMORY_NEEDED */ + ++ /* Find the largest class for which every register number plus N is valid in ++ M1 (if in range). Abort if no such class exists. */ ++ ++ static enum reg_class ++ find_valid_class (m1, n) ++ enum machine_mode m1; ++ int n; ++ { ++ int class; ++ int regno; ++ enum reg_class best_class; ++ int best_size = 0; ++ ++ for (class = 1; class < N_REG_CLASSES; class++) ++ { ++ int bad = 0; ++ for (regno = 0; regno < FIRST_PSEUDO_REGISTER && ! bad; regno++) ++ if (TEST_HARD_REG_BIT (reg_class_contents[class], regno) ++ && TEST_HARD_REG_BIT (reg_class_contents[class], regno + n) ++ && ! HARD_REGNO_MODE_OK (regno + n, m1)) ++ bad = 1; ++ ++ if (! bad && reg_class_size[class] > best_size) ++ best_class = class, best_size = reg_class_size[class]; ++ } ++ ++ if (best_size == 0) ++ abort (); ++ ++ return best_class; ++ } ++ + /* Record one reload that needs to be performed. + IN is an rtx saying where the data are to be found before this instruction. +*************** push_reload (in, out, inloc, outloc, cla +*** 894,898 **** + && GET_CODE (SUBREG_REG (in)) == REG + && REGNO (SUBREG_REG (in)) < FIRST_PSEUDO_REGISTER +! && (! HARD_REGNO_MODE_OK (REGNO (SUBREG_REG (in)), inmode) + || (GET_MODE_SIZE (inmode) <= UNITS_PER_WORD + && (GET_MODE_SIZE (GET_MODE (SUBREG_REG (in))) +--- 927,932 ---- + && GET_CODE (SUBREG_REG (in)) == REG + && REGNO (SUBREG_REG (in)) < FIRST_PSEUDO_REGISTER +! && (! HARD_REGNO_MODE_OK (REGNO (SUBREG_REG (in)) + SUBREG_WORD (in), +! inmode) + || (GET_MODE_SIZE (inmode) <= UNITS_PER_WORD + && (GET_MODE_SIZE (GET_MODE (SUBREG_REG (in))) +*************** push_reload (in, out, inloc, outloc, cla +*** 909,913 **** + output before the outer reload. */ + push_reload (SUBREG_REG (in), NULL_RTX, &SUBREG_REG (in), NULL_PTR, +! GENERAL_REGS, VOIDmode, VOIDmode, 0, 0, opnum, type); + dont_remove_subreg = 1; + } +--- 943,948 ---- + output before the outer reload. */ + push_reload (SUBREG_REG (in), NULL_RTX, &SUBREG_REG (in), NULL_PTR, +! find_valid_class (inmode, SUBREG_WORD (in)), +! VOIDmode, VOIDmode, 0, 0, opnum, type); + dont_remove_subreg = 1; + } +*************** push_reload (in, out, inloc, outloc, cla +*** 982,986 **** + && GET_CODE (SUBREG_REG (out)) == REG + && REGNO (SUBREG_REG (out)) < FIRST_PSEUDO_REGISTER +! && (! HARD_REGNO_MODE_OK (REGNO (SUBREG_REG (out)), outmode) + || (GET_MODE_SIZE (outmode) <= UNITS_PER_WORD + && (GET_MODE_SIZE (GET_MODE (SUBREG_REG (out))) +--- 1017,1022 ---- + && GET_CODE (SUBREG_REG (out)) == REG + && REGNO (SUBREG_REG (out)) < FIRST_PSEUDO_REGISTER +! && (! HARD_REGNO_MODE_OK (REGNO (SUBREG_REG (out)) + SUBREG_WORD (out), +! outmode) + || (GET_MODE_SIZE (outmode) <= UNITS_PER_WORD + && (GET_MODE_SIZE (GET_MODE (SUBREG_REG (out))) +*************** push_reload (in, out, inloc, outloc, cla +*** 998,1002 **** + dont_remove_subreg = 1; + push_reload (SUBREG_REG (out), SUBREG_REG (out), &SUBREG_REG (out), +! &SUBREG_REG (out), ALL_REGS, VOIDmode, VOIDmode, 0, 0, + opnum, RELOAD_OTHER); + } +--- 1034,1040 ---- + dont_remove_subreg = 1; + push_reload (SUBREG_REG (out), SUBREG_REG (out), &SUBREG_REG (out), +! &SUBREG_REG (out), +! find_valid_class (outmode, SUBREG_WORD (out)), +! VOIDmode, VOIDmode, 0, 0, + opnum, RELOAD_OTHER); + } +*************** find_reloads (insn, replace, ind_levels, +*** 2241,2244 **** +--- 2279,2283 ---- + int goal_earlyclobber, this_earlyclobber; + enum machine_mode operand_mode[MAX_RECOG_OPERANDS]; ++ short force_update[MAX_RECOG_OPERANDS]; + + this_insn = insn; +*************** find_reloads (insn, replace, ind_levels, +*** 2272,2275 **** +--- 2311,2316 ---- + #endif + ++ bzero ((char *) force_update, sizeof force_update); ++ + /* Find what kind of insn this is. NOPERANDS gets number of operands. + Make OPERANDS point to a vector of operand values. +*************** find_reloads (insn, replace, ind_levels, +*** 2469,2473 **** + find_reloads_address (VOIDmode, NULL_PTR, + recog_operand[i], recog_operand_loc[i], +! i, operand_type[i], ind_levels); + substed_operand[i] = recog_operand[i] = *recog_operand_loc[i]; + } +--- 2510,2515 ---- + find_reloads_address (VOIDmode, NULL_PTR, + recog_operand[i], recog_operand_loc[i], +! i, operand_type[i], ind_levels, +! &force_update[i]); + substed_operand[i] = recog_operand[i] = *recog_operand_loc[i]; + } +*************** find_reloads (insn, replace, ind_levels, +*** 2478,2482 **** + XEXP (recog_operand[i], 0), + &XEXP (recog_operand[i], 0), +! i, address_type[i], ind_levels)) + address_reloaded[i] = 1; + substed_operand[i] = recog_operand[i] = *recog_operand_loc[i]; +--- 2520,2525 ---- + XEXP (recog_operand[i], 0), + &XEXP (recog_operand[i], 0), +! i, address_type[i], ind_levels, +! &force_update[i])) + address_reloaded[i] = 1; + substed_operand[i] = recog_operand[i] = *recog_operand_loc[i]; +*************** find_reloads (insn, replace, ind_levels, +*** 2487,2491 **** + ind_levels, + set != 0 +! && &SET_DEST (set) == recog_operand_loc[i]); + else if (code == PLUS) + /* We can get a PLUS as an "operand" as a result of +--- 2530,2535 ---- + ind_levels, + set != 0 +! && &SET_DEST (set) == recog_operand_loc[i], +! &force_update[i]); + else if (code == PLUS) + /* We can get a PLUS as an "operand" as a result of +*************** find_reloads (insn, replace, ind_levels, +*** 2493,2497 **** + substed_operand[i] = recog_operand[i] = *recog_operand_loc[i] + = find_reloads_toplev (recog_operand[i], i, address_type[i], +! ind_levels, 0); + else if (code == REG) + { +--- 2537,2541 ---- + substed_operand[i] = recog_operand[i] = *recog_operand_loc[i] + = find_reloads_toplev (recog_operand[i], i, address_type[i], +! ind_levels, 0, &force_update[i]); + else if (code == REG) + { +*************** find_reloads (insn, replace, ind_levels, +*** 2505,2510 **** + if (reg_equiv_constant[regno] != 0 + && (set == 0 || &SET_DEST (set) != recog_operand_loc[i])) +! substed_operand[i] = recog_operand[i] +! = reg_equiv_constant[regno]; + #if 0 /* This might screw code in reload1.c to delete prior output-reload + that feeds this insn. */ +--- 2549,2557 ---- + if (reg_equiv_constant[regno] != 0 + && (set == 0 || &SET_DEST (set) != recog_operand_loc[i])) +! { +! substed_operand[i] = recog_operand[i] +! = reg_equiv_constant[regno]; +! force_update[i] = 1; +! } + #if 0 /* This might screw code in reload1.c to delete prior output-reload + that feeds this insn. */ +*************** find_reloads (insn, replace, ind_levels, +*** 2545,2549 **** + XEXP (recog_operand[i], 0), + &XEXP (recog_operand[i], 0), +! i, address_type[i], ind_levels); + substed_operand[i] = recog_operand[i] = *recog_operand_loc[i]; + } +--- 2592,2597 ---- + XEXP (recog_operand[i], 0), + &XEXP (recog_operand[i], 0), +! i, address_type[i], ind_levels, +! &force_update[i]); + substed_operand[i] = recog_operand[i] = *recog_operand_loc[i]; + } +*************** find_reloads (insn, replace, ind_levels, +*** 3415,3419 **** + = find_reloads_toplev (force_const_mem (operand_mode[i], + recog_operand[i]), +! i, address_type[i], ind_levels, 0); + if (alternative_allows_memconst (constraints1[i], + goal_alternative_number)) +--- 3463,3467 ---- + = find_reloads_toplev (force_const_mem (operand_mode[i], + recog_operand[i]), +! i, address_type[i], ind_levels, 0, NULL); + if (alternative_allows_memconst (constraints1[i], + goal_alternative_number)) +*************** find_reloads (insn, replace, ind_levels, +*** 3595,3609 **** + Don't do this if we aren't making replacements because we might be + propagating things allocated by frame pointer elimination into places +! it doesn't expect. */ + +! if (insn_code_number >= 0 && replace) +! for (i = insn_n_dups[insn_code_number] - 1; i >= 0; i--) +! { +! int opno = recog_dup_num[i]; +! *recog_dup_loc[i] = *recog_operand_loc[opno]; +! if (operand_reloadnum[opno] >= 0) +! push_replacement (recog_dup_loc[i], operand_reloadnum[opno], +! insn_operand_mode[insn_code_number][opno]); +! } + + #if 0 +--- 3643,3664 ---- + Don't do this if we aren't making replacements because we might be + propagating things allocated by frame pointer elimination into places +! it doesn't expect. However, always do it for replaces of pseudos +! by constants. */ + +! for (i = insn_n_dups[insn_code_number] - 1; i >= 0; i--) +! { +! int opno = recog_dup_num[i]; +! +! if (! (insn_code_number >= 0 && replace)) +! { +! if (! force_update[opno]) +! continue; +! } +! +! *recog_dup_loc[i] = *recog_operand_loc[opno]; +! if (operand_reloadnum[opno] >= 0) +! push_replacement (recog_dup_loc[i], operand_reloadnum[opno], +! insn_operand_mode[insn_code_number][opno]); +! } + + #if 0 +*************** find_reloads (insn, replace, ind_levels, +*** 3829,3832 **** +--- 3884,3888 ---- + register RTX_CODE code = GET_CODE (recog_operand[i]); + int is_set_dest = GET_CODE (body) == SET && (i == 0); ++ short ign; + + if (insn_code_number >= 0) +*************** find_reloads (insn, replace, ind_levels, +*** 3834,3838 **** + find_reloads_address (VOIDmode, NULL_PTR, + recog_operand[i], recog_operand_loc[i], +! i, RELOAD_FOR_INPUT, ind_levels); + + /* In these cases, we can't tell if the operand is an input +--- 3890,3894 ---- + find_reloads_address (VOIDmode, NULL_PTR, + recog_operand[i], recog_operand_loc[i], +! i, RELOAD_FOR_INPUT, ind_levels, &ign); + + /* In these cases, we can't tell if the operand is an input +*************** find_reloads (insn, replace, ind_levels, +*** 3845,3853 **** + XEXP (recog_operand[i], 0), + &XEXP (recog_operand[i], 0), +! i, RELOAD_OTHER, ind_levels); + if (code == SUBREG) + recog_operand[i] = *recog_operand_loc[i] + = find_reloads_toplev (recog_operand[i], i, RELOAD_OTHER, +! ind_levels, is_set_dest); + if (code == REG) + { +--- 3901,3909 ---- + XEXP (recog_operand[i], 0), + &XEXP (recog_operand[i], 0), +! i, RELOAD_OTHER, ind_levels, &ign); + if (code == SUBREG) + recog_operand[i] = *recog_operand_loc[i] + = find_reloads_toplev (recog_operand[i], i, RELOAD_OTHER, +! ind_levels, is_set_dest, &ign); + if (code == REG) + { +*************** alternative_allows_memconst (constraint, +*** 3908,3915 **** + + IS_SET_DEST is true if X is the destination of a SET, which is not +! appropriate to be replaced by a constant. */ + + static rtx +! find_reloads_toplev (x, opnum, type, ind_levels, is_set_dest) + rtx x; + int opnum; +--- 3964,3974 ---- + + IS_SET_DEST is true if X is the destination of a SET, which is not +! appropriate to be replaced by a constant. +! +! FORCE_UPDATE, if non-NULL, is the address of a SHORT that is set to +! 1 if X is replaced with something based on reg_equiv_constant. */ + + static rtx +! find_reloads_toplev (x, opnum, type, ind_levels, is_set_dest, force_update) + rtx x; + int opnum; +*************** find_reloads_toplev (x, opnum, type, ind +*** 3917,3920 **** +--- 3976,3980 ---- + int ind_levels; + int is_set_dest; ++ short *force_update; + { + register RTX_CODE code = GET_CODE (x); +*************** find_reloads_toplev (x, opnum, type, ind +*** 3928,3932 **** + register int regno = REGNO (x); + if (reg_equiv_constant[regno] != 0 && !is_set_dest) +! x = reg_equiv_constant[regno]; + #if 0 + /* This creates (subreg (mem...)) which would cause an unnecessary +--- 3988,3998 ---- + register int regno = REGNO (x); + if (reg_equiv_constant[regno] != 0 && !is_set_dest) +! { +! x = reg_equiv_constant[regno]; +! if (force_update) +! *force_update = 1; +! else +! abort (); /* Learn why this happens. */ +! } + #if 0 + /* This creates (subreg (mem...)) which would cause an unnecessary +*************** find_reloads_toplev (x, opnum, type, ind +*** 3951,3955 **** + find_reloads_address (GET_MODE (x), NULL_PTR, + XEXP (x, 0), +! &XEXP (x, 0), opnum, type, ind_levels); + } + return x; +--- 4017,4022 ---- + find_reloads_address (GET_MODE (x), NULL_PTR, + XEXP (x, 0), +! &XEXP (x, 0), opnum, type, ind_levels, +! force_update); + } + return x; +*************** find_reloads_toplev (x, opnum, type, ind +*** 3959,3963 **** + rtx tem = x; + find_reloads_address (GET_MODE (x), &tem, XEXP (x, 0), &XEXP (x, 0), +! opnum, type, ind_levels); + return tem; + } +--- 4026,4030 ---- + rtx tem = x; + find_reloads_address (GET_MODE (x), &tem, XEXP (x, 0), &XEXP (x, 0), +! opnum, type, ind_levels, force_update); + return tem; + } +*************** find_reloads_toplev (x, opnum, type, ind +*** 3982,3986 **** + && (tem = gen_lowpart_common (GET_MODE (x), + reg_equiv_constant[regno])) != 0) +! return tem; + + if (GET_MODE_BITSIZE (GET_MODE (x)) == BITS_PER_WORD +--- 4049,4059 ---- + && (tem = gen_lowpart_common (GET_MODE (x), + reg_equiv_constant[regno])) != 0) +! { +! if (force_update) +! *force_update = 1; +! else +! abort (); /* Learn why this happens. */ +! return tem; +! } + + if (GET_MODE_BITSIZE (GET_MODE (x)) == BITS_PER_WORD +*************** find_reloads_toplev (x, opnum, type, ind +*** 3990,3994 **** + SUBREG_WORD (x), 0, + GET_MODE (SUBREG_REG (x)))) != 0) +! return tem; + + if (regno >= FIRST_PSEUDO_REGISTER && reg_renumber[regno] < 0 +--- 4063,4073 ---- + SUBREG_WORD (x), 0, + GET_MODE (SUBREG_REG (x)))) != 0) +! { +! if (force_update) +! *force_update = 1; +! else +! abort (); /* Learn why this happens. */ +! return tem; +! } + + if (regno >= FIRST_PSEUDO_REGISTER && reg_renumber[regno] < 0 +*************** find_reloads_toplev (x, opnum, type, ind +*** 4040,4044 **** + find_reloads_address (GET_MODE (x), NULL_PTR, + XEXP (x, 0), +! &XEXP (x, 0), opnum, type, ind_levels); + } + +--- 4119,4124 ---- + find_reloads_address (GET_MODE (x), NULL_PTR, + XEXP (x, 0), +! &XEXP (x, 0), opnum, type, ind_levels, +! force_update); + } + +*************** find_reloads_toplev (x, opnum, type, ind +*** 4049,4053 **** + if (fmt[i] == 'e') + XEXP (x, i) = find_reloads_toplev (XEXP (x, i), opnum, type, +! ind_levels, is_set_dest); + } + return x; +--- 4129,4133 ---- + if (fmt[i] == 'e') + XEXP (x, i) = find_reloads_toplev (XEXP (x, i), opnum, type, +! ind_levels, is_set_dest, NULL); + } + return x; +*************** make_memloc (ad, regno) +*** 4110,4114 **** + + static int +! find_reloads_address (mode, memrefloc, ad, loc, opnum, type, ind_levels) + enum machine_mode mode; + rtx *memrefloc; +--- 4190,4195 ---- + + static int +! find_reloads_address (mode, memrefloc, ad, loc, opnum, type, ind_levels, +! force_update) + enum machine_mode mode; + rtx *memrefloc; +*************** find_reloads_address (mode, memrefloc, a +*** 4118,4121 **** +--- 4199,4203 ---- + enum reload_type type; + int ind_levels; ++ short *force_update; + { + register int regno; +*************** find_reloads_address (mode, memrefloc, a +*** 4134,4137 **** +--- 4216,4223 ---- + { + *loc = ad = reg_equiv_constant[regno]; ++ if (force_update) ++ *force_update = 1; ++ else ++ abort (); /* Learn why this happens. */ + return 1; + } +*************** find_reloads_address (mode, memrefloc, a +*** 4141,4145 **** + tem = make_memloc (ad, regno); + find_reloads_address (GET_MODE (tem), NULL_PTR, XEXP (tem, 0), +! &XEXP (tem, 0), opnum, type, ind_levels); + push_reload (tem, NULL_RTX, loc, NULL_PTR, BASE_REG_CLASS, + GET_MODE (ad), VOIDmode, 0, 0, +--- 4227,4231 ---- + tem = make_memloc (ad, regno); + find_reloads_address (GET_MODE (tem), NULL_PTR, XEXP (tem, 0), +! &XEXP (tem, 0), opnum, type, ind_levels, NULL); + push_reload (tem, NULL_RTX, loc, NULL_PTR, BASE_REG_CLASS, + GET_MODE (ad), VOIDmode, 0, 0, +*************** find_reloads_address (mode, memrefloc, a +*** 4214,4218 **** + tem = ad; + find_reloads_address (GET_MODE (ad), &tem, XEXP (ad, 0), &XEXP (ad, 0), +! opnum, type, ind_levels == 0 ? 0 : ind_levels - 1); + + /* If tem was changed, then we must create a new memory reference to +--- 4300,4305 ---- + tem = ad; + find_reloads_address (GET_MODE (ad), &tem, XEXP (ad, 0), &XEXP (ad, 0), +! opnum, type, ind_levels == 0 ? 0 : ind_levels - 1, +! NULL); + + /* If tem was changed, then we must create a new memory reference to +*************** find_reloads_address_1 (x, context, loc, +*** 4722,4726 **** + /* First reload the memory location's address. */ + find_reloads_address (GET_MODE (tem), 0, XEXP (tem, 0), +! &XEXP (tem, 0), opnum, type, ind_levels); + /* Put this inside a new increment-expression. */ + x = gen_rtx (GET_CODE (x), GET_MODE (x), tem); +--- 4809,4814 ---- + /* First reload the memory location's address. */ + find_reloads_address (GET_MODE (tem), 0, XEXP (tem, 0), +! &XEXP (tem, 0), opnum, type, ind_levels, +! NULL); + /* Put this inside a new increment-expression. */ + x = gen_rtx (GET_CODE (x), GET_MODE (x), tem); +*************** find_reloads_address_1 (x, context, loc, +*** 4788,4792 **** + find_reloads_address (GET_MODE (x), &XEXP (x, 0), + XEXP (XEXP (x, 0), 0), &XEXP (XEXP (x, 0), 0), +! opnum, type, ind_levels); + + reloadnum = push_reload (x, NULL_RTX, loc, NULL_PTR, +--- 4876,4880 ---- + find_reloads_address (GET_MODE (x), &XEXP (x, 0), + XEXP (XEXP (x, 0), 0), &XEXP (XEXP (x, 0), 0), +! opnum, type, ind_levels, NULL); + + reloadnum = push_reload (x, NULL_RTX, loc, NULL_PTR, +*************** find_reloads_address_1 (x, context, loc, +*** 4818,4822 **** + + find_reloads_address (GET_MODE (x), loc, XEXP (x, 0), &XEXP (x, 0), +! opnum, type, ind_levels); + push_reload (*loc, NULL_RTX, loc, NULL_PTR, + context ? INDEX_REG_CLASS : BASE_REG_CLASS, +--- 4906,4910 ---- + + find_reloads_address (GET_MODE (x), loc, XEXP (x, 0), &XEXP (x, 0), +! opnum, type, ind_levels, NULL); + push_reload (*loc, NULL_RTX, loc, NULL_PTR, + context ? INDEX_REG_CLASS : BASE_REG_CLASS, +*************** find_reloads_address_1 (x, context, loc, +*** 4852,4856 **** + x = make_memloc (x, regno); + find_reloads_address (GET_MODE (x), 0, XEXP (x, 0), &XEXP (x, 0), +! opnum, type, ind_levels); + } + +--- 4940,4944 ---- + x = make_memloc (x, regno); + find_reloads_address (GET_MODE (x), 0, XEXP (x, 0), &XEXP (x, 0), +! opnum, type, ind_levels, NULL); + } + +*************** find_reloads_address_part (x, loc, class +*** 4965,4969 **** + rtx tem = x = force_const_mem (mode, x); + find_reloads_address (mode, &tem, XEXP (tem, 0), &XEXP (tem, 0), +! opnum, type, ind_levels); + } + +--- 5053,5057 ---- + rtx tem = x = force_const_mem (mode, x); + find_reloads_address (mode, &tem, XEXP (tem, 0), &XEXP (tem, 0), +! opnum, type, ind_levels, NULL); + } + +*************** find_reloads_address_part (x, loc, class +*** 4977,4981 **** + x = gen_rtx (PLUS, GET_MODE (x), XEXP (x, 0), tem); + find_reloads_address (mode, &tem, XEXP (tem, 0), &XEXP (tem, 0), +! opnum, type, ind_levels); + } + +--- 5065,5069 ---- + x = gen_rtx (PLUS, GET_MODE (x), XEXP (x, 0), tem); + find_reloads_address (mode, &tem, XEXP (tem, 0), &XEXP (tem, 0), +! opnum, type, ind_levels, NULL); + } + +*************** find_equiv_reg (goal, insn, class, other +*** 5518,5522 **** + and is also a register that appears in the address of GOAL. */ + +! if (goal_mem && value == SET_DEST (PATTERN (where)) + && refers_to_regno_for_reload_p (valueno, + (valueno +--- 5606,5610 ---- + and is also a register that appears in the address of GOAL. */ + +! if (goal_mem && value == SET_DEST (single_set (where)) + && refers_to_regno_for_reload_p (valueno, + (valueno +*************** debug_reload() +*** 5900,5904 **** + + if (reload_nocombine[r]) +! fprintf (stderr, ", can combine", reload_nocombine[r]); + + if (reload_secondary_p[r]) +--- 5988,5992 ---- + + if (reload_nocombine[r]) +! fprintf (stderr, ", can't combine %d", reload_nocombine[r]); + + if (reload_secondary_p[r]) +diff -rcp2N gcc-2.7.2.2/reload1.c g77-new/reload1.c +*** gcc-2.7.2.2/reload1.c Sun Nov 5 11:22:22 1995 +--- g77-new/reload1.c Sun Aug 10 18:47:00 1997 +*************** reload (first, global, dumpfile) +*** 542,546 **** + Also find all paradoxical subregs and find largest such for each pseudo. + On machines with small register classes, record hard registers that +! are used for user variables. These can never be used for spills. */ + + for (insn = first; insn; insn = NEXT_INSN (insn)) +--- 542,548 ---- + Also find all paradoxical subregs and find largest such for each pseudo. + On machines with small register classes, record hard registers that +! are used for user variables. These can never be used for spills. +! Also look for a "constant" NOTE_INSN_SETJMP. This means that all +! caller-saved registers must be marked live. */ + + for (insn = first; insn; insn = NEXT_INSN (insn)) +*************** reload (first, global, dumpfile) +*** 548,551 **** +--- 550,559 ---- + rtx set = single_set (insn); + ++ if (GET_CODE (insn) == NOTE && CONST_CALL_P (insn) ++ && NOTE_LINE_NUMBER (insn) == NOTE_INSN_SETJMP) ++ for (i = 0; i < FIRST_PSEUDO_REGISTER; i++) ++ if (! call_used_regs[i]) ++ regs_ever_live[i] = 1; ++ + if (set != 0 && GET_CODE (SET_DEST (set)) == REG) + { +*************** reload (first, global, dumpfile) +*** 564,568 **** + if (GET_CODE (x) == MEM) + reg_equiv_memory_loc[i] = x; +! else if (CONSTANT_P (x)) + { + if (LEGITIMATE_CONSTANT_P (x)) +--- 572,578 ---- + if (GET_CODE (x) == MEM) + reg_equiv_memory_loc[i] = x; +! else if (CONSTANT_P (x) +! && ! (GET_CODE (x) == CONST +! && GET_CODE (XEXP (x, 0)) == MINUS)) + { + if (LEGITIMATE_CONSTANT_P (x)) +*************** eliminate_regs (x, mem_mode, insn) +*** 2886,2890 **** + + /* Fall through to generic unary operation case. */ +- case USE: + case STRICT_LOW_PART: + case NEG: case NOT: +--- 2896,2899 ---- +*************** eliminate_regs (x, mem_mode, insn) +*** 2975,2978 **** +--- 2984,3000 ---- + return x; + ++ case USE: ++ /* If using a register that is the source of an eliminate we still ++ think can be performed, note it cannot be performed since we don't ++ know how this register is used. */ ++ for (ep = reg_eliminate; ep < ®_eliminate[NUM_ELIMINABLE_REGS]; ep++) ++ if (ep->from_rtx == XEXP (x, 0)) ++ ep->can_eliminate = 0; ++ ++ new = eliminate_regs (XEXP (x, 0), mem_mode, insn); ++ if (new != XEXP (x, 0)) ++ return gen_rtx (code, GET_MODE (x), new); ++ return x; ++ + case CLOBBER: + /* If clobbering a register that is the replacement register for an +*************** gen_reload (out, in, opnum, type) +*** 6736,6741 **** +--- 6758,6765 ---- + if (GET_CODE (in) == PLUS + && (GET_CODE (XEXP (in, 0)) == REG ++ || GET_CODE (XEXP (in, 0)) == SUBREG + || GET_CODE (XEXP (in, 0)) == MEM) + && (GET_CODE (XEXP (in, 1)) == REG ++ || GET_CODE (XEXP (in, 1)) == SUBREG + || CONSTANT_P (XEXP (in, 1)) + || GET_CODE (XEXP (in, 1)) == MEM)) +*************** gen_reload (out, in, opnum, type) +*** 6798,6807 **** + we emit below. */ + +! if (CONSTANT_P (op1) || GET_CODE (op1) == MEM + || (GET_CODE (op1) == REG + && REGNO (op1) >= FIRST_PSEUDO_REGISTER)) + tem = op0, op0 = op1, op1 = tem; + +! emit_insn (gen_move_insn (out, op0)); + + /* If OP0 and OP1 are the same, we can use OUT for OP1. +--- 6822,6831 ---- + we emit below. */ + +! if (CONSTANT_P (op1) || GET_CODE (op1) == MEM || GET_CODE (op1) == SUBREG + || (GET_CODE (op1) == REG + && REGNO (op1) >= FIRST_PSEUDO_REGISTER)) + tem = op0, op0 = op1, op1 = tem; + +! gen_reload (out, op0, opnum, type); + + /* If OP0 and OP1 are the same, we can use OUT for OP1. +*************** gen_reload (out, in, opnum, type) +*** 6831,6835 **** + delete_insns_since (last); + +! emit_insn (gen_move_insn (out, op1)); + emit_insn (gen_add2_insn (out, op0)); + } +--- 6855,6859 ---- + delete_insns_since (last); + +! gen_reload (out, op1, opnum, type); + emit_insn (gen_add2_insn (out, op0)); + } +*************** gen_reload (out, in, opnum, type) +*** 6852,6857 **** + in = gen_rtx (REG, GET_MODE (loc), REGNO (in)); + +! emit_insn (gen_move_insn (loc, in)); +! emit_insn (gen_move_insn (out, loc)); + } + #endif +--- 6876,6881 ---- + in = gen_rtx (REG, GET_MODE (loc), REGNO (in)); + +! gen_reload (loc, in, opnum, type); +! gen_reload (out, loc, opnum, type); + } + #endif +diff -rcp2N gcc-2.7.2.2/rtl.c g77-new/rtl.c +*** gcc-2.7.2.2/rtl.c Thu Jun 15 08:02:59 1995 +--- g77-new/rtl.c Thu Jul 10 20:09:06 1997 +*************** char *reg_note_name[] = { "", "REG_DEAD" +*** 179,183 **** + "REG_NONNEG", "REG_NO_CONFLICT", "REG_UNUSED", + "REG_CC_SETTER", "REG_CC_USER", "REG_LABEL", +! "REG_DEP_ANTI", "REG_DEP_OUTPUT" }; + + /* Allocate an rtx vector of N elements. +--- 179,183 ---- + "REG_NONNEG", "REG_NO_CONFLICT", "REG_UNUSED", + "REG_CC_SETTER", "REG_CC_USER", "REG_LABEL", +! "REG_DEP_ANTI", "REG_DEP_OUTPUT", "REG_NOALIAS" }; + + /* Allocate an rtx vector of N elements. +diff -rcp2N gcc-2.7.2.2/rtl.h g77-new/rtl.h +*** gcc-2.7.2.2/rtl.h Thu Jun 15 08:03:16 1995 +--- g77-new/rtl.h Thu Jul 10 20:09:07 1997 +*************** enum reg_note { REG_DEAD = 1, REG_INC = +*** 349,353 **** + REG_NONNEG = 8, REG_NO_CONFLICT = 9, REG_UNUSED = 10, + REG_CC_SETTER = 11, REG_CC_USER = 12, REG_LABEL = 13, +! REG_DEP_ANTI = 14, REG_DEP_OUTPUT = 15 }; + + /* Define macros to extract and insert the reg-note kind in an EXPR_LIST. */ +--- 349,353 ---- + REG_NONNEG = 8, REG_NO_CONFLICT = 9, REG_UNUSED = 10, + REG_CC_SETTER = 11, REG_CC_USER = 12, REG_LABEL = 13, +! REG_DEP_ANTI = 14, REG_DEP_OUTPUT = 15, REG_NOALIAS = 16 }; + + /* Define macros to extract and insert the reg-note kind in an EXPR_LIST. */ +*************** extern char *reg_note_name[]; +*** 432,436 **** + #define NOTE_INSN_FUNCTION_BEG -13 + +- + #if 0 /* These are not used, and I don't know what they were for. --rms. */ + #define NOTE_DECL_NAME(INSN) ((INSN)->fld[3].rtstr) +--- 432,435 ---- +*************** extern char *note_insn_name[]; +*** 576,579 **** +--- 575,579 ---- + /* For a TRAP_IF rtx, TRAP_CONDITION is an expression. */ + #define TRAP_CONDITION(RTX) ((RTX)->fld[0].rtx) ++ #define TRAP_CODE(RTX) ((RTX)->fld[1].rtint) + + /* 1 in a SYMBOL_REF if it addresses this function's constants pool. */ +*************** extern rtx eliminate_constant_term PROTO +*** 817,820 **** +--- 817,830 ---- + extern rtx expand_complex_abs PROTO((enum machine_mode, rtx, rtx, int)); + extern enum machine_mode choose_hard_reg_mode PROTO((int, int)); ++ extern int rtx_varies_p PROTO((rtx)); ++ extern int may_trap_p PROTO((rtx)); ++ extern int side_effects_p PROTO((rtx)); ++ extern int volatile_refs_p PROTO((rtx)); ++ extern int volatile_insn_p PROTO((rtx)); ++ extern void remove_note PROTO((rtx, rtx)); ++ extern void note_stores PROTO((rtx, void (*)())); ++ extern int refers_to_regno_p PROTO((int, int, rtx, rtx *)); ++ extern int reg_overlap_mentioned_p PROTO((rtx, rtx)); ++ + + /* Maximum number of parallel sets and clobbers in any insn in this fn. +*************** extern rtx *regno_reg_rtx; +*** 967,968 **** +--- 977,987 ---- + + extern int rtx_to_tree_code PROTO((enum rtx_code)); ++ ++ extern int true_dependence PROTO((rtx, enum machine_mode, rtx, int (*)())); ++ extern int read_dependence PROTO((rtx, rtx)); ++ extern int anti_dependence PROTO((rtx, rtx)); ++ extern int output_dependence PROTO((rtx, rtx)); ++ extern void init_alias_analysis PROTO((void)); ++ extern void end_alias_analysis PROTO((void)); ++ extern void mark_user_reg PROTO((rtx)); ++ extern void mark_reg_pointer PROTO((rtx)); +diff -rcp2N gcc-2.7.2.2/sched.c g77-new/sched.c +*** gcc-2.7.2.2/sched.c Thu Jun 15 08:06:39 1995 +--- g77-new/sched.c Sun Aug 10 18:46:13 1997 +*************** Boston, MA 02111-1307, USA. */ +*** 126,129 **** +--- 126,132 ---- + #include "insn-attr.h" + ++ extern char *reg_known_equiv_p; ++ extern rtx *reg_known_value; ++ + #ifdef INSN_SCHEDULING + /* Arrays set up by scheduling for the same respective purposes as +*************** static int *sched_reg_live_length; +*** 143,146 **** +--- 146,150 ---- + by splitting insns. */ + static rtx *reg_last_uses; ++ static int reg_last_uses_size; + static rtx *reg_last_sets; + static regset reg_pending_sets; +*************** struct sometimes +*** 294,302 **** + + /* Forward declarations. */ +- static rtx canon_rtx PROTO((rtx)); +- static int rtx_equal_for_memref_p PROTO((rtx, rtx)); +- static rtx find_symbolic_term PROTO((rtx)); +- static int memrefs_conflict_p PROTO((int, rtx, int, rtx, +- HOST_WIDE_INT)); + static void add_dependence PROTO((rtx, rtx, enum reg_note)); + static void remove_dependence PROTO((rtx, rtx)); +--- 298,301 ---- +*************** static int priority PROTO((rtx)); +*** 314,318 **** + static void free_pending_lists PROTO((void)); + static void add_insn_mem_dependence PROTO((rtx *, rtx *, rtx, rtx)); +! static void flush_pending_lists PROTO((rtx)); + static void sched_analyze_1 PROTO((rtx, rtx)); + static void sched_analyze_2 PROTO((rtx, rtx)); +--- 313,317 ---- + static void free_pending_lists PROTO((void)); + static void add_insn_mem_dependence PROTO((rtx *, rtx *, rtx, rtx)); +! static void flush_pending_lists PROTO((rtx, int)); + static void sched_analyze_1 PROTO((rtx, rtx)); + static void sched_analyze_2 PROTO((rtx, rtx)); +*************** void schedule_insns PROTO((FILE *)); +*** 346,885 **** + #endif /* INSN_SCHEDULING */ + +- #define SIZE_FOR_MODE(X) (GET_MODE_SIZE (GET_MODE (X))) +- +- /* Vector indexed by N giving the initial (unchanging) value known +- for pseudo-register N. */ +- static rtx *reg_known_value; +- +- /* Vector recording for each reg_known_value whether it is due to a +- REG_EQUIV note. Future passes (viz., reload) may replace the +- pseudo with the equivalent expression and so we account for the +- dependences that would be introduced if that happens. */ +- /* ??? This is a problem only on the Convex. The REG_EQUIV notes created in +- assign_parms mention the arg pointer, and there are explicit insns in the +- RTL that modify the arg pointer. Thus we must ensure that such insns don't +- get scheduled across each other because that would invalidate the REG_EQUIV +- notes. One could argue that the REG_EQUIV notes are wrong, but solving +- the problem in the scheduler will likely give better code, so we do it +- here. */ +- static char *reg_known_equiv_p; +- +- /* Indicates number of valid entries in reg_known_value. */ +- static int reg_known_value_size; +- +- static rtx +- canon_rtx (x) +- rtx x; +- { +- if (GET_CODE (x) == REG && REGNO (x) >= FIRST_PSEUDO_REGISTER +- && REGNO (x) <= reg_known_value_size) +- return reg_known_value[REGNO (x)]; +- else if (GET_CODE (x) == PLUS) +- { +- rtx x0 = canon_rtx (XEXP (x, 0)); +- rtx x1 = canon_rtx (XEXP (x, 1)); +- +- if (x0 != XEXP (x, 0) || x1 != XEXP (x, 1)) +- { +- /* We can tolerate LO_SUMs being offset here; these +- rtl are used for nothing other than comparisons. */ +- if (GET_CODE (x0) == CONST_INT) +- return plus_constant_for_output (x1, INTVAL (x0)); +- else if (GET_CODE (x1) == CONST_INT) +- return plus_constant_for_output (x0, INTVAL (x1)); +- return gen_rtx (PLUS, GET_MODE (x), x0, x1); +- } +- } +- return x; +- } +- +- /* Set up all info needed to perform alias analysis on memory references. */ +- +- void +- init_alias_analysis () +- { +- int maxreg = max_reg_num (); +- rtx insn; +- rtx note; +- rtx set; +- +- reg_known_value_size = maxreg; +- +- reg_known_value +- = (rtx *) oballoc ((maxreg-FIRST_PSEUDO_REGISTER) * sizeof (rtx)) +- - FIRST_PSEUDO_REGISTER; +- bzero ((char *) (reg_known_value + FIRST_PSEUDO_REGISTER), +- (maxreg-FIRST_PSEUDO_REGISTER) * sizeof (rtx)); +- +- reg_known_equiv_p +- = (char *) oballoc ((maxreg -FIRST_PSEUDO_REGISTER) * sizeof (char)) +- - FIRST_PSEUDO_REGISTER; +- bzero (reg_known_equiv_p + FIRST_PSEUDO_REGISTER, +- (maxreg - FIRST_PSEUDO_REGISTER) * sizeof (char)); +- +- /* Fill in the entries with known constant values. */ +- for (insn = get_insns (); insn; insn = NEXT_INSN (insn)) +- if ((set = single_set (insn)) != 0 +- && GET_CODE (SET_DEST (set)) == REG +- && REGNO (SET_DEST (set)) >= FIRST_PSEUDO_REGISTER +- && (((note = find_reg_note (insn, REG_EQUAL, 0)) != 0 +- && reg_n_sets[REGNO (SET_DEST (set))] == 1) +- || (note = find_reg_note (insn, REG_EQUIV, NULL_RTX)) != 0) +- && GET_CODE (XEXP (note, 0)) != EXPR_LIST) +- { +- int regno = REGNO (SET_DEST (set)); +- reg_known_value[regno] = XEXP (note, 0); +- reg_known_equiv_p[regno] = REG_NOTE_KIND (note) == REG_EQUIV; +- } +- +- /* Fill in the remaining entries. */ +- while (--maxreg >= FIRST_PSEUDO_REGISTER) +- if (reg_known_value[maxreg] == 0) +- reg_known_value[maxreg] = regno_reg_rtx[maxreg]; +- } +- +- /* Return 1 if X and Y are identical-looking rtx's. +- +- We use the data in reg_known_value above to see if two registers with +- different numbers are, in fact, equivalent. */ +- +- static int +- rtx_equal_for_memref_p (x, y) +- rtx x, y; +- { +- register int i; +- register int j; +- register enum rtx_code code; +- register char *fmt; +- +- if (x == 0 && y == 0) +- return 1; +- if (x == 0 || y == 0) +- return 0; +- x = canon_rtx (x); +- y = canon_rtx (y); +- +- if (x == y) +- return 1; +- +- code = GET_CODE (x); +- /* Rtx's of different codes cannot be equal. */ +- if (code != GET_CODE (y)) +- return 0; +- +- /* (MULT:SI x y) and (MULT:HI x y) are NOT equivalent. +- (REG:SI x) and (REG:HI x) are NOT equivalent. */ +- +- if (GET_MODE (x) != GET_MODE (y)) +- return 0; +- +- /* REG, LABEL_REF, and SYMBOL_REF can be compared nonrecursively. */ +- +- if (code == REG) +- return REGNO (x) == REGNO (y); +- if (code == LABEL_REF) +- return XEXP (x, 0) == XEXP (y, 0); +- if (code == SYMBOL_REF) +- return XSTR (x, 0) == XSTR (y, 0); +- +- /* For commutative operations, the RTX match if the operand match in any +- order. Also handle the simple binary and unary cases without a loop. */ +- if (code == EQ || code == NE || GET_RTX_CLASS (code) == 'c') +- return ((rtx_equal_for_memref_p (XEXP (x, 0), XEXP (y, 0)) +- && rtx_equal_for_memref_p (XEXP (x, 1), XEXP (y, 1))) +- || (rtx_equal_for_memref_p (XEXP (x, 0), XEXP (y, 1)) +- && rtx_equal_for_memref_p (XEXP (x, 1), XEXP (y, 0)))); +- else if (GET_RTX_CLASS (code) == '<' || GET_RTX_CLASS (code) == '2') +- return (rtx_equal_for_memref_p (XEXP (x, 0), XEXP (y, 0)) +- && rtx_equal_for_memref_p (XEXP (x, 1), XEXP (y, 1))); +- else if (GET_RTX_CLASS (code) == '1') +- return rtx_equal_for_memref_p (XEXP (x, 0), XEXP (y, 0)); +- +- /* Compare the elements. If any pair of corresponding elements +- fail to match, return 0 for the whole things. */ +- +- fmt = GET_RTX_FORMAT (code); +- for (i = GET_RTX_LENGTH (code) - 1; i >= 0; i--) +- { +- switch (fmt[i]) +- { +- case 'w': +- if (XWINT (x, i) != XWINT (y, i)) +- return 0; +- break; +- +- case 'n': +- case 'i': +- if (XINT (x, i) != XINT (y, i)) +- return 0; +- break; +- +- case 'V': +- case 'E': +- /* Two vectors must have the same length. */ +- if (XVECLEN (x, i) != XVECLEN (y, i)) +- return 0; +- +- /* And the corresponding elements must match. */ +- for (j = 0; j < XVECLEN (x, i); j++) +- if (rtx_equal_for_memref_p (XVECEXP (x, i, j), XVECEXP (y, i, j)) == 0) +- return 0; +- break; +- +- case 'e': +- if (rtx_equal_for_memref_p (XEXP (x, i), XEXP (y, i)) == 0) +- return 0; +- break; +- +- case 'S': +- case 's': +- if (strcmp (XSTR (x, i), XSTR (y, i))) +- return 0; +- break; +- +- case 'u': +- /* These are just backpointers, so they don't matter. */ +- break; +- +- case '0': +- break; +- +- /* It is believed that rtx's at this level will never +- contain anything but integers and other rtx's, +- except for within LABEL_REFs and SYMBOL_REFs. */ +- default: +- abort (); +- } +- } +- return 1; +- } +- +- /* Given an rtx X, find a SYMBOL_REF or LABEL_REF within +- X and return it, or return 0 if none found. */ +- +- static rtx +- find_symbolic_term (x) +- rtx x; +- { +- register int i; +- register enum rtx_code code; +- register char *fmt; +- +- code = GET_CODE (x); +- if (code == SYMBOL_REF || code == LABEL_REF) +- return x; +- if (GET_RTX_CLASS (code) == 'o') +- return 0; +- +- fmt = GET_RTX_FORMAT (code); +- for (i = GET_RTX_LENGTH (code) - 1; i >= 0; i--) +- { +- rtx t; +- +- if (fmt[i] == 'e') +- { +- t = find_symbolic_term (XEXP (x, i)); +- if (t != 0) +- return t; +- } +- else if (fmt[i] == 'E') +- break; +- } +- return 0; +- } +- +- /* Return nonzero if X and Y (memory addresses) could reference the +- same location in memory. C is an offset accumulator. When +- C is nonzero, we are testing aliases between X and Y + C. +- XSIZE is the size in bytes of the X reference, +- similarly YSIZE is the size in bytes for Y. +- +- If XSIZE or YSIZE is zero, we do not know the amount of memory being +- referenced (the reference was BLKmode), so make the most pessimistic +- assumptions. +- +- We recognize the following cases of non-conflicting memory: +- +- (1) addresses involving the frame pointer cannot conflict +- with addresses involving static variables. +- (2) static variables with different addresses cannot conflict. +- +- Nice to notice that varying addresses cannot conflict with fp if no +- local variables had their addresses taken, but that's too hard now. */ +- +- /* ??? In Fortran, references to a array parameter can never conflict with +- another array parameter. */ +- +- static int +- memrefs_conflict_p (xsize, x, ysize, y, c) +- rtx x, y; +- int xsize, ysize; +- HOST_WIDE_INT c; +- { +- if (GET_CODE (x) == HIGH) +- x = XEXP (x, 0); +- else if (GET_CODE (x) == LO_SUM) +- x = XEXP (x, 1); +- else +- x = canon_rtx (x); +- if (GET_CODE (y) == HIGH) +- y = XEXP (y, 0); +- else if (GET_CODE (y) == LO_SUM) +- y = XEXP (y, 1); +- else +- y = canon_rtx (y); +- +- if (rtx_equal_for_memref_p (x, y)) +- return (xsize == 0 || ysize == 0 || +- (c >= 0 && xsize > c) || (c < 0 && ysize+c > 0)); +- +- if (y == frame_pointer_rtx || y == hard_frame_pointer_rtx +- || y == stack_pointer_rtx) +- { +- rtx t = y; +- int tsize = ysize; +- y = x; ysize = xsize; +- x = t; xsize = tsize; +- } +- +- if (x == frame_pointer_rtx || x == hard_frame_pointer_rtx +- || x == stack_pointer_rtx) +- { +- rtx y1; +- +- if (CONSTANT_P (y)) +- return 0; +- +- if (GET_CODE (y) == PLUS +- && canon_rtx (XEXP (y, 0)) == x +- && (y1 = canon_rtx (XEXP (y, 1))) +- && GET_CODE (y1) == CONST_INT) +- { +- c += INTVAL (y1); +- return (xsize == 0 || ysize == 0 +- || (c >= 0 && xsize > c) || (c < 0 && ysize+c > 0)); +- } +- +- if (GET_CODE (y) == PLUS +- && (y1 = canon_rtx (XEXP (y, 0))) +- && CONSTANT_P (y1)) +- return 0; +- +- return 1; +- } +- +- if (GET_CODE (x) == PLUS) +- { +- /* The fact that X is canonicalized means that this +- PLUS rtx is canonicalized. */ +- rtx x0 = XEXP (x, 0); +- rtx x1 = XEXP (x, 1); +- +- if (GET_CODE (y) == PLUS) +- { +- /* The fact that Y is canonicalized means that this +- PLUS rtx is canonicalized. */ +- rtx y0 = XEXP (y, 0); +- rtx y1 = XEXP (y, 1); +- +- if (rtx_equal_for_memref_p (x1, y1)) +- return memrefs_conflict_p (xsize, x0, ysize, y0, c); +- if (rtx_equal_for_memref_p (x0, y0)) +- return memrefs_conflict_p (xsize, x1, ysize, y1, c); +- if (GET_CODE (x1) == CONST_INT) +- if (GET_CODE (y1) == CONST_INT) +- return memrefs_conflict_p (xsize, x0, ysize, y0, +- c - INTVAL (x1) + INTVAL (y1)); +- else +- return memrefs_conflict_p (xsize, x0, ysize, y, c - INTVAL (x1)); +- else if (GET_CODE (y1) == CONST_INT) +- return memrefs_conflict_p (xsize, x, ysize, y0, c + INTVAL (y1)); +- +- /* Handle case where we cannot understand iteration operators, +- but we notice that the base addresses are distinct objects. */ +- x = find_symbolic_term (x); +- if (x == 0) +- return 1; +- y = find_symbolic_term (y); +- if (y == 0) +- return 1; +- return rtx_equal_for_memref_p (x, y); +- } +- else if (GET_CODE (x1) == CONST_INT) +- return memrefs_conflict_p (xsize, x0, ysize, y, c - INTVAL (x1)); +- } +- else if (GET_CODE (y) == PLUS) +- { +- /* The fact that Y is canonicalized means that this +- PLUS rtx is canonicalized. */ +- rtx y0 = XEXP (y, 0); +- rtx y1 = XEXP (y, 1); +- +- if (GET_CODE (y1) == CONST_INT) +- return memrefs_conflict_p (xsize, x, ysize, y0, c + INTVAL (y1)); +- else +- return 1; +- } +- +- if (GET_CODE (x) == GET_CODE (y)) +- switch (GET_CODE (x)) +- { +- case MULT: +- { +- /* Handle cases where we expect the second operands to be the +- same, and check only whether the first operand would conflict +- or not. */ +- rtx x0, y0; +- rtx x1 = canon_rtx (XEXP (x, 1)); +- rtx y1 = canon_rtx (XEXP (y, 1)); +- if (! rtx_equal_for_memref_p (x1, y1)) +- return 1; +- x0 = canon_rtx (XEXP (x, 0)); +- y0 = canon_rtx (XEXP (y, 0)); +- if (rtx_equal_for_memref_p (x0, y0)) +- return (xsize == 0 || ysize == 0 +- || (c >= 0 && xsize > c) || (c < 0 && ysize+c > 0)); +- +- /* Can't properly adjust our sizes. */ +- if (GET_CODE (x1) != CONST_INT) +- return 1; +- xsize /= INTVAL (x1); +- ysize /= INTVAL (x1); +- c /= INTVAL (x1); +- return memrefs_conflict_p (xsize, x0, ysize, y0, c); +- } +- } +- +- if (CONSTANT_P (x)) +- { +- if (GET_CODE (x) == CONST_INT && GET_CODE (y) == CONST_INT) +- { +- c += (INTVAL (y) - INTVAL (x)); +- return (xsize == 0 || ysize == 0 +- || (c >= 0 && xsize > c) || (c < 0 && ysize+c > 0)); +- } +- +- if (GET_CODE (x) == CONST) +- { +- if (GET_CODE (y) == CONST) +- return memrefs_conflict_p (xsize, canon_rtx (XEXP (x, 0)), +- ysize, canon_rtx (XEXP (y, 0)), c); +- else +- return memrefs_conflict_p (xsize, canon_rtx (XEXP (x, 0)), +- ysize, y, c); +- } +- if (GET_CODE (y) == CONST) +- return memrefs_conflict_p (xsize, x, ysize, +- canon_rtx (XEXP (y, 0)), c); +- +- if (CONSTANT_P (y)) +- return (rtx_equal_for_memref_p (x, y) +- && (xsize == 0 || ysize == 0 +- || (c >= 0 && xsize > c) || (c < 0 && ysize+c > 0))); +- +- return 1; +- } +- return 1; +- } +- +- /* Functions to compute memory dependencies. +- +- Since we process the insns in execution order, we can build tables +- to keep track of what registers are fixed (and not aliased), what registers +- are varying in known ways, and what registers are varying in unknown +- ways. +- +- If both memory references are volatile, then there must always be a +- dependence between the two references, since their order can not be +- changed. A volatile and non-volatile reference can be interchanged +- though. +- +- A MEM_IN_STRUCT reference at a non-QImode varying address can never +- conflict with a non-MEM_IN_STRUCT reference at a fixed address. We must +- allow QImode aliasing because the ANSI C standard allows character +- pointers to alias anything. We are assuming that characters are +- always QImode here. */ +- +- /* Read dependence: X is read after read in MEM takes place. There can +- only be a dependence here if both reads are volatile. */ +- +- int +- read_dependence (mem, x) +- rtx mem; +- rtx x; +- { +- return MEM_VOLATILE_P (x) && MEM_VOLATILE_P (mem); +- } +- +- /* True dependence: X is read after store in MEM takes place. */ +- +- int +- true_dependence (mem, x) +- rtx mem; +- rtx x; +- { +- /* If X is an unchanging read, then it can't possibly conflict with any +- non-unchanging store. It may conflict with an unchanging write though, +- because there may be a single store to this address to initialize it. +- Just fall through to the code below to resolve the case where we have +- both an unchanging read and an unchanging write. This won't handle all +- cases optimally, but the possible performance loss should be +- negligible. */ +- if (RTX_UNCHANGING_P (x) && ! RTX_UNCHANGING_P (mem)) +- return 0; +- +- return ((MEM_VOLATILE_P (x) && MEM_VOLATILE_P (mem)) +- || (memrefs_conflict_p (SIZE_FOR_MODE (mem), XEXP (mem, 0), +- SIZE_FOR_MODE (x), XEXP (x, 0), 0) +- && ! (MEM_IN_STRUCT_P (mem) && rtx_addr_varies_p (mem) +- && GET_MODE (mem) != QImode +- && ! MEM_IN_STRUCT_P (x) && ! rtx_addr_varies_p (x)) +- && ! (MEM_IN_STRUCT_P (x) && rtx_addr_varies_p (x) +- && GET_MODE (x) != QImode +- && ! MEM_IN_STRUCT_P (mem) && ! rtx_addr_varies_p (mem)))); +- } +- +- /* Anti dependence: X is written after read in MEM takes place. */ +- +- int +- anti_dependence (mem, x) +- rtx mem; +- rtx x; +- { +- /* If MEM is an unchanging read, then it can't possibly conflict with +- the store to X, because there is at most one store to MEM, and it must +- have occurred somewhere before MEM. */ +- if (RTX_UNCHANGING_P (mem)) +- return 0; +- +- return ((MEM_VOLATILE_P (x) && MEM_VOLATILE_P (mem)) +- || (memrefs_conflict_p (SIZE_FOR_MODE (mem), XEXP (mem, 0), +- SIZE_FOR_MODE (x), XEXP (x, 0), 0) +- && ! (MEM_IN_STRUCT_P (mem) && rtx_addr_varies_p (mem) +- && GET_MODE (mem) != QImode +- && ! MEM_IN_STRUCT_P (x) && ! rtx_addr_varies_p (x)) +- && ! (MEM_IN_STRUCT_P (x) && rtx_addr_varies_p (x) +- && GET_MODE (x) != QImode +- && ! MEM_IN_STRUCT_P (mem) && ! rtx_addr_varies_p (mem)))); +- } +- +- /* Output dependence: X is written after store in MEM takes place. */ +- +- int +- output_dependence (mem, x) +- rtx mem; +- rtx x; +- { +- return ((MEM_VOLATILE_P (x) && MEM_VOLATILE_P (mem)) +- || (memrefs_conflict_p (SIZE_FOR_MODE (mem), XEXP (mem, 0), +- SIZE_FOR_MODE (x), XEXP (x, 0), 0) +- && ! (MEM_IN_STRUCT_P (mem) && rtx_addr_varies_p (mem) +- && GET_MODE (mem) != QImode +- && ! MEM_IN_STRUCT_P (x) && ! rtx_addr_varies_p (x)) +- && ! (MEM_IN_STRUCT_P (x) && rtx_addr_varies_p (x) +- && GET_MODE (x) != QImode +- && ! MEM_IN_STRUCT_P (mem) && ! rtx_addr_varies_p (mem)))); +- } +- + /* Helper functions for instruction scheduling. */ + +--- 345,348 ---- +*************** add_insn_mem_dependence (insn_list, mem_ +*** 1609,1621 **** + + /* Make a dependency between every memory reference on the pending lists +! and INSN, thus flushing the pending lists. */ + + static void +! flush_pending_lists (insn) + rtx insn; + { + rtx link; + +! while (pending_read_insns) + { + add_dependence (insn, XEXP (pending_read_insns, 0), REG_DEP_ANTI); +--- 1072,1086 ---- + + /* Make a dependency between every memory reference on the pending lists +! and INSN, thus flushing the pending lists. If ONLY_WRITE, don't flush +! the read list. */ + + static void +! flush_pending_lists (insn, only_write) + rtx insn; ++ int only_write; + { + rtx link; + +! while (pending_read_insns && ! only_write) + { + add_dependence (insn, XEXP (pending_read_insns, 0), REG_DEP_ANTI); +*************** sched_analyze_1 (x, insn) +*** 1746,1750 **** + this flush occurs 8 times for sparc, and 10 times for m88k using + the number 32. */ +! flush_pending_lists (insn); + } + else +--- 1211,1215 ---- + this flush occurs 8 times for sparc, and 10 times for m88k using + the number 32. */ +! flush_pending_lists (insn, 0); + } + else +*************** sched_analyze_2 (x, insn) +*** 1922,1926 **** + /* If a dependency already exists, don't create a new one. */ + if (! find_insn_list (XEXP (pending, 0), LOG_LINKS (insn))) +! if (true_dependence (XEXP (pending_mem, 0), x)) + add_dependence (insn, XEXP (pending, 0), 0); + +--- 1387,1392 ---- + /* If a dependency already exists, don't create a new one. */ + if (! find_insn_list (XEXP (pending, 0), LOG_LINKS (insn))) +! if (true_dependence (XEXP (pending_mem, 0), VOIDmode, +! x, rtx_varies_p)) + add_dependence (insn, XEXP (pending, 0), 0); + +*************** sched_analyze_2 (x, insn) +*** 1968,1972 **** + reg_pending_sets_all = 1; + +! flush_pending_lists (insn); + } + +--- 1434,1438 ---- + reg_pending_sets_all = 1; + +! flush_pending_lists (insn, 0); + } + +*************** sched_analyze_insn (x, insn, loop_notes) +*** 2021,2025 **** + register RTX_CODE code = GET_CODE (x); + rtx link; +! int maxreg = max_reg_num (); + int i; + +--- 1487,1491 ---- + register RTX_CODE code = GET_CODE (x); + rtx link; +! int maxreg = reg_last_uses_size; + int i; + +*************** sched_analyze_insn (x, insn, loop_notes) +*** 2058,2062 **** + if (loop_notes) + { +! int max_reg = max_reg_num (); + rtx link; + +--- 1524,1528 ---- + if (loop_notes) + { +! int max_reg = reg_last_uses_size; + rtx link; + +*************** sched_analyze_insn (x, insn, loop_notes) +*** 2072,2076 **** + reg_pending_sets_all = 1; + +! flush_pending_lists (insn); + + link = loop_notes; +--- 1538,1542 ---- + reg_pending_sets_all = 1; + +! flush_pending_lists (insn, 0); + + link = loop_notes; +*************** sched_analyze (head, tail) +*** 2202,2207 **** + && NOTE_LINE_NUMBER (NEXT_INSN (insn)) == NOTE_INSN_SETJMP) + { +! int max_reg = max_reg_num (); +! for (i = 0; i < max_reg; i++) + { + for (u = reg_last_uses[i]; u; u = XEXP (u, 1)) +--- 1668,1672 ---- + && NOTE_LINE_NUMBER (NEXT_INSN (insn)) == NOTE_INSN_SETJMP) + { +! for (i = 0; i < reg_last_uses_size; i++) + { + for (u = reg_last_uses[i]; u; u = XEXP (u, 1)) +*************** sched_analyze (head, tail) +*** 2247,2259 **** + loop_notes = 0; + +! /* We don't need to flush memory for a function call which does +! not involve memory. */ +! if (! CONST_CALL_P (insn)) +! { +! /* In the absence of interprocedural alias analysis, +! we must flush all pending reads and writes, and +! start new dependencies starting from here. */ +! flush_pending_lists (insn); +! } + + /* Depend this function call (actually, the user of this +--- 1712,1720 ---- + loop_notes = 0; + +! /* In the absence of interprocedural alias analysis, we must flush +! all pending reads and writes, and start new dependencies starting +! from here. But only flush writes for constant calls (which may +! be passed a pointer to something we haven't written yet). */ +! flush_pending_lists (insn, CONST_CALL_P (insn)); + + /* Depend this function call (actually, the user of this +*************** sched_analyze (head, tail) +*** 2264,2270 **** + else if (GET_CODE (insn) == NOTE + && (NOTE_LINE_NUMBER (insn) == NOTE_INSN_LOOP_BEG +! || NOTE_LINE_NUMBER (insn) == NOTE_INSN_LOOP_END)) +! loop_notes = gen_rtx (EXPR_LIST, REG_DEAD, +! GEN_INT (NOTE_LINE_NUMBER (insn)), loop_notes); + + if (insn == tail) +--- 1725,1736 ---- + else if (GET_CODE (insn) == NOTE + && (NOTE_LINE_NUMBER (insn) == NOTE_INSN_LOOP_BEG +! || NOTE_LINE_NUMBER (insn) == NOTE_INSN_LOOP_END +! || (NOTE_LINE_NUMBER (insn) == NOTE_INSN_SETJMP +! && GET_CODE (PREV_INSN (insn)) != CALL_INSN))) +! { +! loop_notes = gen_rtx (EXPR_LIST, REG_DEAD, +! GEN_INT (NOTE_LINE_NUMBER (insn)), loop_notes); +! CONST_CALL_P (loop_notes) = CONST_CALL_P (insn); +! } + + if (insn == tail) +*************** sched_note_set (b, x, death) +*** 2372,2380 **** + + #define SCHED_SORT(READY, NEW_READY, OLD_READY) \ +! do { if ((NEW_READY) - (OLD_READY) == 1) \ +! swap_sort (READY, NEW_READY); \ +! else if ((NEW_READY) - (OLD_READY) > 1) \ +! qsort (READY, NEW_READY, sizeof (rtx), rank_for_schedule); } \ +! while (0) + + /* Returns a positive value if y is preferred; returns a negative value if +--- 1838,1845 ---- + + #define SCHED_SORT(READY, NEW_READY, OLD_READY) \ +! if ((NEW_READY) - (OLD_READY) == 1) \ +! swap_sort (READY, NEW_READY); \ +! else if ((NEW_READY) - (OLD_READY) > 1) \ +! qsort (READY, NEW_READY, sizeof (rtx), rank_for_schedule); else \ + + /* Returns a positive value if y is preferred; returns a negative value if +*************** reemit_notes (insn, last) +*** 3128,3132 **** + { + if (INTVAL (XEXP (note, 0)) == NOTE_INSN_SETJMP) +! emit_note_after (INTVAL (XEXP (note, 0)), insn); + else + last = emit_note_before (INTVAL (XEXP (note, 0)), last); +--- 2593,2598 ---- + { + if (INTVAL (XEXP (note, 0)) == NOTE_INSN_SETJMP) +! CONST_CALL_P (emit_note_after (INTVAL (XEXP (note, 0)), insn)) +! = CONST_CALL_P (note); + else + last = emit_note_before (INTVAL (XEXP (note, 0)), last); +*************** schedule_block (b, file) +*** 3174,3178 **** + b, INSN_UID (basic_block_head[b]), INSN_UID (basic_block_end[b])); + +! i = max_reg_num (); + reg_last_uses = (rtx *) alloca (i * sizeof (rtx)); + bzero ((char *) reg_last_uses, i * sizeof (rtx)); +--- 2640,2644 ---- + b, INSN_UID (basic_block_head[b]), INSN_UID (basic_block_end[b])); + +! reg_last_uses_size = i = max_reg_num (); + reg_last_uses = (rtx *) alloca (i * sizeof (rtx)); + bzero ((char *) reg_last_uses, i * sizeof (rtx)); +*************** schedule_block (b, file) +*** 3800,3804 **** + made live again later. */ + for (i = 0; i < FIRST_PSEUDO_REGISTER; i++) +! if (call_used_regs[i] || global_regs[i]) + { + register int offset = i / REGSET_ELT_BITS; +--- 3266,3271 ---- + made live again later. */ + for (i = 0; i < FIRST_PSEUDO_REGISTER; i++) +! if ((call_used_regs[i] && ! fixed_regs[i]) +! || global_regs[i]) + { + register int offset = i / REGSET_ELT_BITS; +*************** schedule_insns (dump_file) +*** 4717,4721 **** + bcopy ((char *) reg_n_deaths, (char *) sched_reg_n_deaths, + max_regno * sizeof (short)); +- init_alias_analysis (); + } + else +--- 4184,4187 ---- +*************** schedule_insns (dump_file) +*** 4726,4732 **** + bb_dead_regs = 0; + bb_live_regs = 0; +- if (! flag_schedule_insns) +- init_alias_analysis (); + } + + if (write_symbols != NO_DEBUG) +--- 4192,4213 ---- + bb_dead_regs = 0; + bb_live_regs = 0; + } ++ init_alias_analysis (); ++ #if 0 ++ if (dump_file) ++ { ++ extern rtx *reg_base_value; ++ extern int reg_base_value_size; ++ int i; ++ for (i = 0; i < reg_base_value_size; i++) ++ if (reg_base_value[i]) ++ { ++ fprintf (dump_file, ";; reg_base_value[%d] = ", i); ++ print_rtl (dump_file, reg_base_value[i]); ++ fputc ('\n', dump_file); ++ } ++ } ++ #endif ++ + + if (write_symbols != NO_DEBUG) +diff -rcp2N gcc-2.7.2.2/sdbout.c g77-new/sdbout.c +*** gcc-2.7.2.2/sdbout.c Thu Jun 15 08:07:11 1995 +--- g77-new/sdbout.c Mon Aug 11 01:42:22 1997 +*************** plain_type_1 (type, level) +*** 539,543 **** + sdb_dims[sdb_n_dims++] + = (TYPE_DOMAIN (type) +! ? TREE_INT_CST_LOW (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) + 1 + : 0); + return PUSH_DERIVED_LEVEL (DT_ARY, m); +--- 539,546 ---- + sdb_dims[sdb_n_dims++] + = (TYPE_DOMAIN (type) +! && TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INTEGER_CST +! && TREE_CODE (TYPE_MIN_VALUE (TYPE_DOMAIN (type))) == INTEGER_CST +! ? (TREE_INT_CST_LOW (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) +! - TREE_INT_CST_LOW (TYPE_MIN_VALUE (TYPE_DOMAIN (type))) + 1) + : 0); + return PUSH_DERIVED_LEVEL (DT_ARY, m); +diff -rcp2N gcc-2.7.2.2/stmt.c g77-new/stmt.c +*** gcc-2.7.2.2/stmt.c Tue Sep 12 19:01:54 1995 +--- g77-new/stmt.c Sun Aug 10 18:46:56 1997 +*************** fixup_gotos (thisblock, stack_level, cle +*** 1244,1249 **** + poplevel (1, 0, 0); + end_sequence (); +! f->before_jump +! = emit_insns_after (cleanup_insns, f->before_jump); + + f->cleanup_list_list = TREE_CHAIN (lists); +--- 1244,1250 ---- + poplevel (1, 0, 0); + end_sequence (); +! if (cleanup_insns != 0) +! f->before_jump +! = emit_insns_after (cleanup_insns, f->before_jump); + + f->cleanup_list_list = TREE_CHAIN (lists); +*************** expand_expr_stmt (exp) +*** 1721,1725 **** + + last_expr_type = TREE_TYPE (exp); +! if (! flag_syntax_only) + last_expr_value = expand_expr (exp, + (expr_stmts_for_value +--- 1722,1726 ---- + + last_expr_type = TREE_TYPE (exp); +! if (! flag_syntax_only || expr_stmts_for_value) + last_expr_value = expand_expr (exp, + (expr_stmts_for_value +*************** expand_end_bindings (vars, mark_ends, do +*** 3160,3163 **** +--- 3161,3169 ---- + #endif + ++ #ifdef HAVE_nonlocal_goto_receiver ++ if (HAVE_nonlocal_goto_receiver) ++ emit_insn (gen_nonlocal_goto_receiver ()); ++ #endif ++ + /* The handler expects the desired label address in the static chain + register. It tests the address and does an appropriate jump +*************** expand_decl (decl) +*** 3369,3393 **** + = promote_mode (type, DECL_MODE (decl), &unsignedp, 0); + +! if (TREE_CODE (type) == COMPLEX_TYPE) +! { +! rtx realpart, imagpart; +! enum machine_mode partmode = TYPE_MODE (TREE_TYPE (type)); + +! /* For a complex type variable, make a CONCAT of two pseudos +! so that the real and imaginary parts +! can be allocated separately. */ +! realpart = gen_reg_rtx (partmode); +! REG_USERVAR_P (realpart) = 1; +! imagpart = gen_reg_rtx (partmode); +! REG_USERVAR_P (imagpart) = 1; +! DECL_RTL (decl) = gen_rtx (CONCAT, reg_mode, realpart, imagpart); +! } +! else +! { +! DECL_RTL (decl) = gen_reg_rtx (reg_mode); +! if (TREE_CODE (type) == POINTER_TYPE) +! mark_reg_pointer (DECL_RTL (decl)); +! REG_USERVAR_P (DECL_RTL (decl)) = 1; +! } + } + else if (TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST) +--- 3375,3383 ---- + = promote_mode (type, DECL_MODE (decl), &unsignedp, 0); + +! DECL_RTL (decl) = gen_reg_rtx (reg_mode); +! mark_user_reg (DECL_RTL (decl)); + +! if (TREE_CODE (type) == POINTER_TYPE) +! mark_reg_pointer (DECL_RTL (decl)); + } + else if (TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST) +*************** expand_decl (decl) +*** 3462,3468 **** + free_temp_slots (); + +! /* Allocate space on the stack for the variable. */ + address = allocate_dynamic_stack_space (size, NULL_RTX, +! DECL_ALIGN (decl)); + + /* Reference the variable indirect through that rtx. */ +--- 3452,3461 ---- + free_temp_slots (); + +! /* Allocate space on the stack for the variable. Note that +! DECL_ALIGN says how the variable is to be aligned and we +! cannot use it to conclude anything about the alignment of +! the size. */ + address = allocate_dynamic_stack_space (size, NULL_RTX, +! TYPE_ALIGN (TREE_TYPE (decl))); + + /* Reference the variable indirect through that rtx. */ +diff -rcp2N gcc-2.7.2.2/stor-layout.c g77-new/stor-layout.c +*** gcc-2.7.2.2/stor-layout.c Thu Feb 20 19:24:20 1997 +--- g77-new/stor-layout.c Mon Aug 11 06:47:50 1997 +*************** layout_decl (decl, known_align) +*** 255,259 **** + if (maximum_field_alignment != 0) + DECL_ALIGN (decl) = MIN (DECL_ALIGN (decl), maximum_field_alignment); +! else if (flag_pack_struct) + DECL_ALIGN (decl) = MIN (DECL_ALIGN (decl), BITS_PER_UNIT); + } +--- 255,259 ---- + if (maximum_field_alignment != 0) + DECL_ALIGN (decl) = MIN (DECL_ALIGN (decl), maximum_field_alignment); +! else if (DECL_PACKED (decl)) + DECL_ALIGN (decl) = MIN (DECL_ALIGN (decl), BITS_PER_UNIT); + } +*************** layout_decl (decl, known_align) +*** 261,265 **** + if (DECL_BIT_FIELD (decl) + && TYPE_SIZE (type) != 0 +! && TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST) + { + register enum machine_mode xmode +--- 261,266 ---- + if (DECL_BIT_FIELD (decl) + && TYPE_SIZE (type) != 0 +! && TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST +! && GET_MODE_CLASS (TYPE_MODE (type)) == MODE_INT) + { + register enum machine_mode xmode +*************** layout_decl (decl, known_align) +*** 278,281 **** +--- 279,291 ---- + } + ++ /* Turn off DECL_BIT_FIELD if we won't need it set. */ ++ if (DECL_BIT_FIELD (decl) && TYPE_MODE (type) == BLKmode ++ && known_align % TYPE_ALIGN (type) == 0 ++ && DECL_SIZE (decl) != 0 ++ && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST ++ || (TREE_INT_CST_LOW (DECL_SIZE (decl)) % BITS_PER_UNIT) == 0) ++ && DECL_ALIGN (decl) >= TYPE_ALIGN (type)) ++ DECL_BIT_FIELD (decl) = 0; ++ + /* Evaluate nonconstant size only once, either now or as soon as safe. */ + if (DECL_SIZE (decl) != 0 && TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST) +*************** layout_record (rec) +*** 380,384 **** + if (maximum_field_alignment != 0) + type_align = MIN (type_align, maximum_field_alignment); +! else if (flag_pack_struct) + type_align = MIN (type_align, BITS_PER_UNIT); + +--- 390,394 ---- + if (maximum_field_alignment != 0) + type_align = MIN (type_align, maximum_field_alignment); +! else if (TYPE_PACKED (rec)) + type_align = MIN (type_align, BITS_PER_UNIT); + +*************** layout_record (rec) +*** 422,428 **** + && DECL_BIT_FIELD_TYPE (field) + && !DECL_PACKED (field) +- /* If #pragma pack is in effect, turn off this feature. */ + && maximum_field_alignment == 0 +- && !flag_pack_struct + && !integer_zerop (DECL_SIZE (field))) + { +--- 432,436 ---- +*************** layout_record (rec) +*** 459,463 **** + if (maximum_field_alignment != 0) + type_align = MIN (type_align, maximum_field_alignment); +! else if (flag_pack_struct) + type_align = MIN (type_align, BITS_PER_UNIT); + +--- 467,471 ---- + if (maximum_field_alignment != 0) + type_align = MIN (type_align, maximum_field_alignment); +! else if (TYPE_PACKED (rec)) + type_align = MIN (type_align, BITS_PER_UNIT); + +*************** layout_record (rec) +*** 500,505 **** + /* Do nothing. */; + else if (TREE_CODE (dsize) == INTEGER_CST + && TREE_INT_CST_HIGH (dsize) == 0 +! && TREE_INT_CST_LOW (dsize) + const_size > const_size) + /* Use const_size if there's no overflow. */ + const_size += TREE_INT_CST_LOW (dsize); +--- 508,514 ---- + /* Do nothing. */; + else if (TREE_CODE (dsize) == INTEGER_CST ++ && ! TREE_CONSTANT_OVERFLOW (dsize) + && TREE_INT_CST_HIGH (dsize) == 0 +! && TREE_INT_CST_LOW (dsize) + const_size >= const_size) + /* Use const_size if there's no overflow. */ + const_size += TREE_INT_CST_LOW (dsize); +*************** get_best_mode (bitsize, bitpos, align, l +*** 1172,1175 **** +--- 1181,1192 ---- + enum machine_mode mode; + int unit; ++ ++ if (bitpos < 0) ++ { ++ /* For correct calculations and convenience, bias negative bitpos ++ to become a non-negative value that is [1,bitsize], such that ++ the relative bit offset to a multiple of bitsize is preserved. */ ++ bitpos = bitsize - ((-bitpos) % bitsize); ++ } + + /* Find the narrowest integer mode that contains the bit field. */ +diff -rcp2N gcc-2.7.2.2/stupid.c g77-new/stupid.c +*** gcc-2.7.2.2/stupid.c Sun Oct 29 07:45:22 1995 +--- g77-new/stupid.c Sun Aug 10 18:46:01 1997 +*************** static int *uid_suid; +*** 66,69 **** +--- 66,74 ---- + static int last_call_suid; + ++ /* Record the suid of the last NOTE_INSN_SETJMP ++ so we can tell whether a pseudo reg crosses any setjmp. */ ++ ++ static int last_setjmp_suid; ++ + /* Element N is suid of insn where life span of pseudo reg N ends. + Element is 0 if register N has not been seen yet on backward scan. */ +*************** static char *regs_live; +*** 89,92 **** +--- 94,101 ---- + static char *regs_change_size; + ++ /* Indexed by reg number, nonzero if reg crosses a setjmp. */ ++ ++ static char *regs_crosses_setjmp; ++ + /* Indexed by insn's suid, the set of hard regs live after that insn. */ + +*************** stupid_life_analysis (f, nregs, file) +*** 149,152 **** +--- 158,162 ---- + + last_call_suid = i + 1; ++ last_setjmp_suid = i + 1; + max_suid = i + 1; + +*************** stupid_life_analysis (f, nregs, file) +*** 167,170 **** +--- 177,183 ---- + bzero ((char *) regs_change_size, nregs * sizeof (char)); + ++ regs_crosses_setjmp = (char *) alloca (nregs * sizeof (char)); ++ bzero ((char *) regs_crosses_setjmp, nregs * sizeof (char)); ++ + reg_renumber = (short *) oballoc (nregs * sizeof (short)); + for (i = 0; i < FIRST_PSEUDO_REGISTER; i++) +*************** stupid_life_analysis (f, nregs, file) +*** 216,219 **** +--- 229,236 ---- + stupid_mark_refs (PATTERN (insn), insn); + ++ if (GET_CODE (insn) == NOTE ++ && NOTE_LINE_NUMBER (insn) == NOTE_INSN_SETJMP) ++ last_setjmp_suid = INSN_SUID (insn); ++ + /* Mark all call-clobbered regs as live after each call insn + so that a pseudo whose life span includes this insn +*************** stupid_life_analysis (f, nregs, file) +*** 254,259 **** + register int r = reg_order[i]; + +! /* Some regnos disappear from the rtl. Ignore them to avoid crash. */ +! if (regno_reg_rtx[r] == 0) + continue; + +--- 271,277 ---- + register int r = reg_order[i]; + +! /* Some regnos disappear from the rtl. Ignore them to avoid crash. +! Also don't allocate registers that cross a setjmp. */ +! if (regno_reg_rtx[r] == 0 || regs_crosses_setjmp[r]) + continue; + +*************** stupid_reg_compare (r1p, r2p) +*** 309,314 **** + that can hold a value of machine-mode MODE + (but actually we test only the first of the block for holding MODE) +! currently free from after insn whose suid is BIRTH +! through the insn whose suid is DEATH, + and return the number of the first of them. + Return -1 if such a block cannot be found. +--- 327,332 ---- + that can hold a value of machine-mode MODE + (but actually we test only the first of the block for holding MODE) +! currently free from after insn whose suid is BORN_INSN +! through the insn whose suid is DEAD_INSN, + and return the number of the first of them. + Return -1 if such a block cannot be found. +*************** stupid_find_reg (call_preserved, class, +*** 338,341 **** +--- 356,366 ---- + #endif + ++ /* If this register's life is more than 5,000 insns, we probably ++ can't allocate it, so don't waste the time trying. This avoid ++ quadratic behavior on programs that have regularly-occurring ++ SAVE_EXPRs. */ ++ if (dead_insn > born_insn + 5000) ++ return -1; ++ + COPY_HARD_REG_SET (used, + call_preserved ? call_used_reg_set : fixed_reg_set); +*************** stupid_mark_refs (x, insn) +*** 488,491 **** +--- 513,519 ---- + if (last_call_suid < reg_where_dead[regno]) + reg_n_calls_crossed[regno] += 1; ++ ++ if (last_setjmp_suid < reg_where_dead[regno]) ++ regs_crosses_setjmp[regno] = 1; + } + } +diff -rcp2N gcc-2.7.2.2/toplev.c g77-new/toplev.c +*** gcc-2.7.2.2/toplev.c Fri Oct 20 17:56:35 1995 +--- g77-new/toplev.c Sun Aug 10 18:43:36 1997 +*************** int flag_unroll_loops; +*** 388,391 **** +--- 388,405 ---- + int flag_unroll_all_loops; + ++ /* Nonzero forces all invariant computations in loops to be moved ++ outside the loop. */ ++ ++ int flag_move_all_movables = 0; ++ ++ /* Nonzero forces all general induction variables in loops to be ++ strength reduced. */ ++ ++ int flag_reduce_all_givs = 0; ++ ++ /* Nonzero gets another run of loop_optimize performed. */ ++ ++ int flag_rerun_loop_opt = 0; ++ + /* Nonzero for -fwritable-strings: + store string constants in data segment and don't uniquize them. */ +*************** int flag_gnu_linker = 1; +*** 522,525 **** +--- 536,550 ---- + int flag_pack_struct = 0; + ++ /* 1 if alias checking is on (by default, when -O). */ ++ int flag_alias_check = 0; ++ ++ /* 0 if pointer arguments may alias each other. True in C. ++ 1 if pointer arguments may not alias each other but may alias ++ global variables. ++ 2 if pointer arguments may not alias each other and may not ++ alias global variables. True in Fortran. ++ This defaults to 0 for C. */ ++ int flag_argument_noalias = 0; ++ + /* Table of language-independent -f options. + STRING is the option name. VARIABLE is the address of the variable. +*************** struct { char *string; int *variable; in +*** 542,545 **** +--- 567,573 ---- + {"unroll-loops", &flag_unroll_loops, 1}, + {"unroll-all-loops", &flag_unroll_all_loops, 1}, ++ {"move-all-movables", &flag_move_all_movables, 1}, ++ {"reduce-all-givs", &flag_reduce_all_givs, 1}, ++ {"rerun-loop-opt", &flag_rerun_loop_opt, 1}, + {"writable-strings", &flag_writable_strings, 1}, + {"peephole", &flag_no_peephole, 0}, +*************** struct { char *string; int *variable; in +*** 568,572 **** + {"gnu-linker", &flag_gnu_linker, 1}, + {"pack-struct", &flag_pack_struct, 1}, +! {"bytecode", &output_bytecode, 1} + }; + +--- 596,604 ---- + {"gnu-linker", &flag_gnu_linker, 1}, + {"pack-struct", &flag_pack_struct, 1}, +! {"bytecode", &output_bytecode, 1}, +! {"alias-check", &flag_alias_check, 1}, +! {"argument-alias", &flag_argument_noalias, 0}, +! {"argument-noalias", &flag_argument_noalias, 1}, +! {"argument-noalias-global", &flag_argument_noalias, 2} + }; + +*************** rest_of_compilation (decl) +*** 2715,2725 **** + finish_compilation will call rest_of_compilation again + for those functions that need to be output. Also defer those +! functions that we are supposed to defer. */ +! +! if (DECL_DEFER_OUTPUT (decl) +! || ((specd || DECL_INLINE (decl)) +! && ((! TREE_PUBLIC (decl) && ! TREE_ADDRESSABLE (decl) +! && ! flag_keep_inline_functions) +! || DECL_EXTERNAL (decl)))) + { + DECL_DEFER_OUTPUT (decl) = 1; +--- 2747,2760 ---- + finish_compilation will call rest_of_compilation again + for those functions that need to be output. Also defer those +! functions that we are supposed to defer. We cannot defer +! functions containing nested functions since the nested function +! data is in our non-saved obstack. */ +! +! if (! current_function_contains_functions +! && (DECL_DEFER_OUTPUT (decl) +! || ((specd || DECL_INLINE (decl)) +! && ((! TREE_PUBLIC (decl) && ! TREE_ADDRESSABLE (decl) +! && ! flag_keep_inline_functions) +! || DECL_EXTERNAL (decl))))) + { + DECL_DEFER_OUTPUT (decl) = 1; +*************** rest_of_compilation (decl) +*** 2893,2897 **** +--- 2928,2951 ---- + TIMEVAR (loop_time, + { ++ int save_unroll_flag; ++ int save_unroll_all_flag; ++ ++ if (flag_rerun_loop_opt) ++ { ++ save_unroll_flag = flag_unroll_loops; ++ save_unroll_all_flag = flag_unroll_all_loops; ++ flag_unroll_loops = 0; ++ flag_unroll_all_loops = 0; ++ } ++ + loop_optimize (insns, loop_dump_file); ++ ++ if (flag_rerun_loop_opt) ++ { ++ flag_unroll_loops = save_unroll_flag; ++ flag_unroll_all_loops = save_unroll_all_flag; ++ ++ loop_optimize (insns, loop_dump_file); ++ } + }); + } +*************** rest_of_compilation (decl) +*** 3280,3283 **** +--- 3334,3341 ---- + resume_temporary_allocation (); + ++ /* Show no temporary slots allocated. */ ++ ++ init_temp_slots (); ++ + /* The parsing time is all the time spent in yyparse + *except* what is spent in this function. */ +*************** main (argc, argv, envp) +*** 3383,3386 **** +--- 3441,3445 ---- + flag_omit_frame_pointer = 1; + #endif ++ flag_alias_check = 1; + } + +diff -rcp2N gcc-2.7.2.2/tree.c g77-new/tree.c +*** gcc-2.7.2.2/tree.c Sun Oct 1 21:26:56 1995 +--- g77-new/tree.c Sun Aug 10 18:47:23 1997 +*************** build_string (len, str) +*** 1428,1436 **** + /* Return a newly constructed COMPLEX_CST node whose value is + specified by the real and imaginary parts REAL and IMAG. +! Both REAL and IMAG should be constant nodes. +! The TREE_TYPE is not initialized. */ + + tree +! build_complex (real, imag) + tree real, imag; + { +--- 1428,1437 ---- + /* Return a newly constructed COMPLEX_CST node whose value is + specified by the real and imaginary parts REAL and IMAG. +! Both REAL and IMAG should be constant nodes. TYPE, if specified, +! will be the type of the COMPLEX_CST; otherwise a new type will be made. */ + + tree +! build_complex (type, real, imag) +! tree type; + tree real, imag; + { +*************** build_complex (real, imag) +*** 1439,1443 **** + TREE_REALPART (t) = real; + TREE_IMAGPART (t) = imag; +! TREE_TYPE (t) = build_complex_type (TREE_TYPE (real)); + TREE_OVERFLOW (t) = TREE_OVERFLOW (real) | TREE_OVERFLOW (imag); + TREE_CONSTANT_OVERFLOW (t) +--- 1440,1444 ---- + TREE_REALPART (t) = real; + TREE_IMAGPART (t) = imag; +! TREE_TYPE (t) = type ? type : build_complex_type (TREE_TYPE (real)); + TREE_OVERFLOW (t) = TREE_OVERFLOW (real) | TREE_OVERFLOW (imag); + TREE_CONSTANT_OVERFLOW (t) +*************** integer_zerop (expr) +*** 1484,1487 **** +--- 1485,1489 ---- + + return ((TREE_CODE (expr) == INTEGER_CST ++ && ! TREE_CONSTANT_OVERFLOW (expr) + && TREE_INT_CST_LOW (expr) == 0 + && TREE_INT_CST_HIGH (expr) == 0) +*************** integer_onep (expr) +*** 1501,1504 **** +--- 1503,1507 ---- + + return ((TREE_CODE (expr) == INTEGER_CST ++ && ! TREE_CONSTANT_OVERFLOW (expr) + && TREE_INT_CST_LOW (expr) == 1 + && TREE_INT_CST_HIGH (expr) == 0) +*************** integer_all_onesp (expr) +*** 1525,1529 **** + return 1; + +! else if (TREE_CODE (expr) != INTEGER_CST) + return 0; + +--- 1528,1533 ---- + return 1; + +! else if (TREE_CODE (expr) != INTEGER_CST +! || TREE_CONSTANT_OVERFLOW (expr)) + return 0; + +*************** integer_pow2p (expr) +*** 1574,1578 **** + return 1; + +! if (TREE_CODE (expr) != INTEGER_CST) + return 0; + +--- 1578,1582 ---- + return 1; + +! if (TREE_CODE (expr) != INTEGER_CST || TREE_CONSTANT_OVERFLOW (expr)) + return 0; + +*************** real_zerop (expr) +*** 1596,1599 **** +--- 1600,1604 ---- + + return ((TREE_CODE (expr) == REAL_CST ++ && ! TREE_CONSTANT_OVERFLOW (expr) + && REAL_VALUES_EQUAL (TREE_REAL_CST (expr), dconst0)) + || (TREE_CODE (expr) == COMPLEX_CST +*************** real_onep (expr) +*** 1611,1614 **** +--- 1616,1620 ---- + + return ((TREE_CODE (expr) == REAL_CST ++ && ! TREE_CONSTANT_OVERFLOW (expr) + && REAL_VALUES_EQUAL (TREE_REAL_CST (expr), dconst1)) + || (TREE_CODE (expr) == COMPLEX_CST +*************** real_twop (expr) +*** 1626,1629 **** +--- 1632,1636 ---- + + return ((TREE_CODE (expr) == REAL_CST ++ && ! TREE_CONSTANT_OVERFLOW (expr) + && REAL_VALUES_EQUAL (TREE_REAL_CST (expr), dconst2)) + || (TREE_CODE (expr) == COMPLEX_CST +*************** staticp (arg) +*** 2055,2061 **** + return 1; + + case COMPONENT_REF: + case BIT_FIELD_REF: +! return staticp (TREE_OPERAND (arg, 0)); + + #if 0 +--- 2062,2073 ---- + return 1; + ++ /* If we are referencing a bitfield, we can't evaluate an ++ ADDR_EXPR at compile time and so it isn't a constant. */ + case COMPONENT_REF: ++ return (! DECL_BIT_FIELD (TREE_OPERAND (arg, 1)) ++ && staticp (TREE_OPERAND (arg, 0))); ++ + case BIT_FIELD_REF: +! return 0; + + #if 0 +*************** contains_placeholder_p (exp) +*** 2157,2160 **** +--- 2169,2174 ---- + if (code == WITH_RECORD_EXPR) + return 0; ++ else if (code == PLACEHOLDER_EXPR) ++ return 1; + + switch (TREE_CODE_CLASS (code)) +*************** substitute_in_expr (exp, f, r) +*** 2204,2207 **** +--- 2218,2222 ---- + { + enum tree_code code = TREE_CODE (exp); ++ tree op0, op1, op2; + tree new = 0; + tree inner; +*************** substitute_in_expr (exp, f, r) +*** 2225,2231 **** + { + case 1: +! new = fold (build1 (code, TREE_TYPE (exp), +! substitute_in_expr (TREE_OPERAND (exp, 0), +! f, r))); + break; + +--- 2240,2248 ---- + { + case 1: +! op0 = substitute_in_expr (TREE_OPERAND (exp, 0), f, r); +! if (op0 == TREE_OPERAND (exp, 0)) +! return exp; +! +! new = fold (build1 (code, TREE_TYPE (exp), op0)); + break; + +*************** substitute_in_expr (exp, f, r) +*** 2238,2245 **** + abort (); + +! new = fold (build (code, TREE_TYPE (exp), +! substitute_in_expr (TREE_OPERAND (exp, 0), f, r), +! substitute_in_expr (TREE_OPERAND (exp, 1), +! f, r))); + break; + +--- 2255,2264 ---- + abort (); + +! op0 = substitute_in_expr (TREE_OPERAND (exp, 0), f, r); +! op1 = substitute_in_expr (TREE_OPERAND (exp, 1), f, r); +! if (op0 == TREE_OPERAND (exp, 0) && op1 == TREE_OPERAND (exp, 1)) +! return exp; +! +! new = fold (build (code, TREE_TYPE (exp), op0, op1)); + break; + +*************** substitute_in_expr (exp, f, r) +*** 2253,2261 **** + abort (); + +! new = fold (build (code, TREE_TYPE (exp), +! substitute_in_expr (TREE_OPERAND (exp, 0), f, r), +! substitute_in_expr (TREE_OPERAND (exp, 1), f, r), +! substitute_in_expr (TREE_OPERAND (exp, 2), +! f, r))); + } + +--- 2272,2283 ---- + abort (); + +! op0 = substitute_in_expr (TREE_OPERAND (exp, 0), f, r); +! op1 = substitute_in_expr (TREE_OPERAND (exp, 1), f, r); +! op2 = substitute_in_expr (TREE_OPERAND (exp, 2), f, r); +! if (op0 == TREE_OPERAND (exp, 0) && op1 == TREE_OPERAND (exp, 1) +! && op2 == TREE_OPERAND (exp, 2)) +! return exp; +! +! new = fold (build (code, TREE_TYPE (exp), op0, op1, op2)); + } + +*************** substitute_in_expr (exp, f, r) +*** 2276,2302 **** + return r; + +! new = fold (build (code, TREE_TYPE (exp), +! substitute_in_expr (TREE_OPERAND (exp, 0), f, r), + TREE_OPERAND (exp, 1))); + break; + + case BIT_FIELD_REF: +! new = fold (build (code, TREE_TYPE (exp), +! substitute_in_expr (TREE_OPERAND (exp, 0), f, r), +! substitute_in_expr (TREE_OPERAND (exp, 1), f, r), +! substitute_in_expr (TREE_OPERAND (exp, 2), f, r))); + break; + + case INDIRECT_REF: + case BUFFER_REF: +! new = fold (build1 (code, TREE_TYPE (exp), +! substitute_in_expr (TREE_OPERAND (exp, 0), +! f, r))); + break; + + case OFFSET_REF: +! new = fold (build (code, TREE_TYPE (exp), +! substitute_in_expr (TREE_OPERAND (exp, 0), f, r), +! substitute_in_expr (TREE_OPERAND (exp, 1), f, r))); + break; + } +--- 2298,2342 ---- + return r; + +! /* If this expression hasn't been completed let, leave it +! alone. */ +! if (TREE_CODE (inner) == PLACEHOLDER_EXPR +! && TREE_TYPE (inner) == 0) +! return exp; +! +! op0 = substitute_in_expr (TREE_OPERAND (exp, 0), f, r); +! if (op0 == TREE_OPERAND (exp, 0)) +! return exp; +! +! new = fold (build (code, TREE_TYPE (exp), op0, + TREE_OPERAND (exp, 1))); + break; + + case BIT_FIELD_REF: +! op0 = substitute_in_expr (TREE_OPERAND (exp, 0), f, r); +! op1 = substitute_in_expr (TREE_OPERAND (exp, 1), f, r); +! op2 = substitute_in_expr (TREE_OPERAND (exp, 2), f, r); +! if (op0 == TREE_OPERAND (exp, 0) && op1 == TREE_OPERAND (exp, 1) +! && op2 == TREE_OPERAND (exp, 2)) +! return exp; +! +! new = fold (build (code, TREE_TYPE (exp), op0, op1, op2)); + break; + + case INDIRECT_REF: + case BUFFER_REF: +! op0 = substitute_in_expr (TREE_OPERAND (exp, 0), f, r); +! if (op0 == TREE_OPERAND (exp, 0)) +! return exp; +! +! new = fold (build1 (code, TREE_TYPE (exp), op0)); + break; + + case OFFSET_REF: +! op0 = substitute_in_expr (TREE_OPERAND (exp, 0), f, r); +! op1 = substitute_in_expr (TREE_OPERAND (exp, 1), f, r); +! if (op0 == TREE_OPERAND (exp, 0) && op1 == TREE_OPERAND (exp, 1)) +! return exp; +! +! new = fold (build (code, TREE_TYPE (exp), op0, op1)); + break; + } +*************** substitute_in_expr (exp, f, r) +*** 2311,2454 **** + } + +- /* Given a type T, a FIELD_DECL F, and a replacement value R, +- return a new type with all size expressions that contain F +- updated by replacing F with R. */ +- +- tree +- substitute_in_type (t, f, r) +- tree t, f, r; +- { +- switch (TREE_CODE (t)) +- { +- case POINTER_TYPE: +- case VOID_TYPE: +- return t; +- case INTEGER_TYPE: +- case ENUMERAL_TYPE: +- case BOOLEAN_TYPE: +- case CHAR_TYPE: +- if ((TREE_CODE (TYPE_MIN_VALUE (t)) != INTEGER_CST +- && contains_placeholder_p (TYPE_MIN_VALUE (t))) +- || (TREE_CODE (TYPE_MAX_VALUE (t)) != INTEGER_CST +- && contains_placeholder_p (TYPE_MAX_VALUE (t)))) +- return build_range_type (t, +- substitute_in_expr (TYPE_MIN_VALUE (t), f, r), +- substitute_in_expr (TYPE_MAX_VALUE (t), f, r)); +- return t; +- +- case REAL_TYPE: +- if ((TYPE_MIN_VALUE (t) != 0 +- && TREE_CODE (TYPE_MIN_VALUE (t)) != REAL_CST +- && contains_placeholder_p (TYPE_MIN_VALUE (t))) +- || (TYPE_MAX_VALUE (t) != 0 +- && TREE_CODE (TYPE_MAX_VALUE (t)) != REAL_CST +- && contains_placeholder_p (TYPE_MAX_VALUE (t)))) +- { +- t = build_type_copy (t); +- +- if (TYPE_MIN_VALUE (t)) +- TYPE_MIN_VALUE (t) = substitute_in_expr (TYPE_MIN_VALUE (t), f, r); +- if (TYPE_MAX_VALUE (t)) +- TYPE_MAX_VALUE (t) = substitute_in_expr (TYPE_MAX_VALUE (t), f, r); +- } +- return t; +- +- case COMPLEX_TYPE: +- return build_complex_type (substitute_in_type (TREE_TYPE (t), f, r)); +- +- case OFFSET_TYPE: +- case METHOD_TYPE: +- case REFERENCE_TYPE: +- case FILE_TYPE: +- case SET_TYPE: +- case FUNCTION_TYPE: +- case LANG_TYPE: +- /* Don't know how to do these yet. */ +- abort (); +- +- case ARRAY_TYPE: +- t = build_array_type (substitute_in_type (TREE_TYPE (t), f, r), +- substitute_in_type (TYPE_DOMAIN (t), f, r)); +- TYPE_SIZE (t) = 0; +- layout_type (t); +- return t; +- +- case RECORD_TYPE: +- case UNION_TYPE: +- case QUAL_UNION_TYPE: +- { +- tree new = copy_node (t); +- tree field; +- tree last_field = 0; +- +- /* Start out with no fields, make new fields, and chain them +- in. */ +- +- TYPE_FIELDS (new) = 0; +- TYPE_SIZE (new) = 0; +- +- for (field = TYPE_FIELDS (t); field; +- field = TREE_CHAIN (field)) +- { +- tree new_field = copy_node (field); +- +- TREE_TYPE (new_field) +- = substitute_in_type (TREE_TYPE (new_field), f, r); +- +- /* If this is an anonymous field and the type of this field is +- a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If +- the type just has one element, treat that as the field. +- But don't do this if we are processing a QUAL_UNION_TYPE. */ +- if (TREE_CODE (t) != QUAL_UNION_TYPE && DECL_NAME (new_field) == 0 +- && (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE +- || TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE)) +- { +- if (TYPE_FIELDS (TREE_TYPE (new_field)) == 0) +- continue; +- +- if (TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field))) == 0) +- new_field = TYPE_FIELDS (TREE_TYPE (new_field)); +- } +- +- DECL_CONTEXT (new_field) = new; +- DECL_SIZE (new_field) = 0; +- +- if (TREE_CODE (t) == QUAL_UNION_TYPE) +- { +- /* Do the substitution inside the qualifier and if we find +- that this field will not be present, omit it. */ +- DECL_QUALIFIER (new_field) +- = substitute_in_expr (DECL_QUALIFIER (field), f, r); +- if (integer_zerop (DECL_QUALIFIER (new_field))) +- continue; +- } +- +- if (last_field == 0) +- TYPE_FIELDS (new) = new_field; +- else +- TREE_CHAIN (last_field) = new_field; +- +- last_field = new_field; +- +- /* If this is a qualified type and this field will always be +- present, we are done. */ +- if (TREE_CODE (t) == QUAL_UNION_TYPE +- && integer_onep (DECL_QUALIFIER (new_field))) +- break; +- } +- +- /* If this used to be a qualified union type, but we now know what +- field will be present, make this a normal union. */ +- if (TREE_CODE (new) == QUAL_UNION_TYPE +- && (TYPE_FIELDS (new) == 0 +- || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new))))) +- TREE_SET_CODE (new, UNION_TYPE); +- +- layout_type (new); +- return new; +- } +- } +- } +- + /* Stabilize a reference so that we can use it any number of times + without causing its operands to be evaluated more than once. +--- 2351,2354 ---- +*************** build_type_variant (type, constp, volati +*** 3141,3145 **** + preserve the TYPE_NAME, since there is code that depends on this. */ + +! for (t = TYPE_MAIN_VARIANT(type); t; t = TYPE_NEXT_VARIANT (t)) + if (constp == TYPE_READONLY (t) && volatilep == TYPE_VOLATILE (t) + && TYPE_NAME (t) == TYPE_NAME (type)) +--- 3041,3045 ---- + preserve the TYPE_NAME, since there is code that depends on this. */ + +! for (t = TYPE_MAIN_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t)) + if (constp == TYPE_READONLY (t) && volatilep == TYPE_VOLATILE (t) + && TYPE_NAME (t) == TYPE_NAME (type)) +*************** get_unwidened (op, for_type) +*** 4051,4055 **** + if (TREE_CODE (op) == COMPONENT_REF + /* Since type_for_size always gives an integer type. */ +! && TREE_CODE (type) != REAL_TYPE) + { + unsigned innerprec = TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (op, 1))); +--- 3951,3957 ---- + if (TREE_CODE (op) == COMPONENT_REF + /* Since type_for_size always gives an integer type. */ +! && TREE_CODE (type) != REAL_TYPE +! /* Don't crash if field not layed out yet. */ +! && DECL_SIZE (TREE_OPERAND (op, 1)) != 0) + { + unsigned innerprec = TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (op, 1))); +diff -rcp2N gcc-2.7.2.2/tree.h g77-new/tree.h +*** gcc-2.7.2.2/tree.h Mon Sep 25 17:49:40 1995 +--- g77-new/tree.h Sun Aug 10 18:47:08 1997 +*************** enum built_in_function +*** 98,101 **** +--- 98,103 ---- + BUILT_IN_APPLY, + BUILT_IN_RETURN, ++ BUILT_IN_SETJMP, ++ BUILT_IN_LONGJMP, + + /* C++ extensions */ +*************** struct tree_int_cst +*** 408,411 **** +--- 410,415 ---- + { + char common[sizeof (struct tree_common)]; ++ struct rtx_def *rtl; /* acts as link to register transfer language ++ (rtl) info */ + HOST_WIDE_INT int_cst_low; + HOST_WIDE_INT int_cst_high; +*************** struct tree_type +*** 957,960 **** +--- 961,967 ---- + #define DECL_STATIC_DESTRUCTOR(NODE) ((NODE)->decl.static_dtor_flag) + ++ /* In a PARM_DECL, nonzero if this is a restricted pointer. */ ++ #define DECL_RESTRICT(NODE) (NODE)->decl.static_ctor_flag ++ + /* Used to indicate that this DECL represents a compiler-generated entity. */ + #define DECL_ARTIFICIAL(NODE) ((NODE)->decl.artificial_flag) +*************** extern tree build_int_2_wide PROTO((HOS +*** 1176,1180 **** + extern tree build_real PROTO((tree, REAL_VALUE_TYPE)); + extern tree build_real_from_int_cst PROTO((tree, tree)); +! extern tree build_complex PROTO((tree, tree)); + extern tree build_string PROTO((int, char *)); + extern tree build1 PROTO((enum tree_code, tree, tree)); +--- 1183,1187 ---- + extern tree build_real PROTO((tree, REAL_VALUE_TYPE)); + extern tree build_real_from_int_cst PROTO((tree, tree)); +! extern tree build_complex PROTO((tree, tree, tree)); + extern tree build_string PROTO((int, char *)); + extern tree build1 PROTO((enum tree_code, tree, tree)); +*************** extern int contains_placeholder_p PROTO( +*** 1378,1387 **** + extern tree substitute_in_expr PROTO((tree, tree, tree)); + +- /* Given a type T, a FIELD_DECL F, and a replacement value R, +- return a new type with all size expressions that contain F +- updated by replacing the reference to F with R. */ +- +- extern tree substitute_in_type PROTO((tree, tree, tree)); +- + /* variable_size (EXP) is like save_expr (EXP) except that it + is for the special case of something that is part of a +--- 1385,1388 ---- +*************** extern tree maybe_build_cleanup PROTO(( +*** 1456,1460 **** + and find the ultimate containing object, which is returned. */ + +! extern tree get_inner_reference PROTO((tree, int *, int *, tree *, enum machine_mode *, int *, int *)); + + /* Return the FUNCTION_DECL which provides this _DECL with its context, +--- 1457,1463 ---- + and find the ultimate containing object, which is returned. */ + +! extern tree get_inner_reference PROTO((tree, int *, int *, tree *, +! enum machine_mode *, int *, +! int *, int *)); + + /* Return the FUNCTION_DECL which provides this _DECL with its context, +diff -rcp2N gcc-2.7.2.2/unroll.c g77-new/unroll.c +*** gcc-2.7.2.2/unroll.c Sat Aug 19 17:33:26 1995 +--- g77-new/unroll.c Thu Jul 10 20:09:10 1997 +*************** unroll_loop (loop_end, insn_count, loop_ +*** 268,273 **** + structure of the function. This can happen as a result of the + "if (foo) bar; else break;" optimization in jump.c. */ + +! if (write_symbols != NO_DEBUG) + { + int block_begins = 0; +--- 268,277 ---- + structure of the function. This can happen as a result of the + "if (foo) bar; else break;" optimization in jump.c. */ ++ /* ??? Gcc has a general policy that -g is never supposed to change the code ++ that the compiler emits, so we must disable this optimization always, ++ even if debug info is not being output. This is rare, so this should ++ not be a significant performance problem. */ + +! if (1 /* write_symbols != NO_DEBUG */) + { + int block_begins = 0; +*************** unroll_loop (loop_end, insn_count, loop_ +*** 633,636 **** +--- 637,657 ---- + } + ++ if (unroll_type == UNROLL_NAIVE ++ && GET_CODE (last_loop_insn) == JUMP_INSN ++ && start_label != JUMP_LABEL (last_loop_insn)) ++ { ++ /* ??? The loop ends with a conditional branch that does not branch back ++ to the loop start label. In this case, we must emit an unconditional ++ branch to the loop exit after emitting the final branch. ++ copy_loop_body does not have support for this currently, so we ++ give up. It doesn't seem worthwhile to unroll anyways since ++ unrolling would increase the number of branch instructions ++ executed. */ ++ if (loop_dump_stream) ++ fprintf (loop_dump_stream, ++ "Unrolling failure: final conditional branch not to loop start\n"); ++ return; ++ } ++ + /* Allocate a translation table for the labels and insn numbers. + They will be filled in as we copy the insns in the loop. */ +*************** unroll_loop (loop_end, insn_count, loop_ +*** 995,999 **** + for (j = FIRST_PSEUDO_REGISTER; j < max_reg_before_loop; j++) + if (local_regno[j]) +! map->reg_map[j] = gen_reg_rtx (GET_MODE (regno_reg_rtx[j])); + + /* The last copy needs the compare/branch insns at the end, +--- 1016,1024 ---- + for (j = FIRST_PSEUDO_REGISTER; j < max_reg_before_loop; j++) + if (local_regno[j]) +! { +! map->reg_map[j] = gen_reg_rtx (GET_MODE (regno_reg_rtx[j])); +! record_base_value (REGNO (map->reg_map[j]), +! regno_reg_rtx[j]); +! } + + /* The last copy needs the compare/branch insns at the end, +*************** unroll_loop (loop_end, insn_count, loop_ +*** 1136,1140 **** + for (j = FIRST_PSEUDO_REGISTER; j < max_reg_before_loop; j++) + if (local_regno[j]) +! map->reg_map[j] = gen_reg_rtx (GET_MODE (regno_reg_rtx[j])); + + /* If loop starts with a branch to the test, then fix it so that +--- 1161,1169 ---- + for (j = FIRST_PSEUDO_REGISTER; j < max_reg_before_loop; j++) + if (local_regno[j]) +! { +! map->reg_map[j] = gen_reg_rtx (GET_MODE (regno_reg_rtx[j])); +! record_base_value (REGNO (map->reg_map[j]), +! regno_reg_rtx[j]); +! } + + /* If loop starts with a branch to the test, then fix it so that +*************** copy_loop_body (copy_start, copy_end, ma +*** 1605,1608 **** +--- 1634,1641 ---- + int this_giv_inc = INTVAL (giv_inc); + ++ /* If this DEST_ADDR giv was not split, then ignore it. */ ++ if (*tv->location != tv->dest_reg) ++ continue; ++ + /* Scale this_giv_inc if the multiplicative factors of + the two givs are different. */ +*************** copy_loop_body (copy_start, copy_end, ma +*** 1631,1635 **** + incrementing the shared pseudo reg more than + once. */ +! if (! tv->same_insn) + { + /* tv->dest_reg may actually be a (PLUS (REG) +--- 1664,1668 ---- + incrementing the shared pseudo reg more than + once. */ +! if (! tv->same_insn && ! tv->shared) + { + /* tv->dest_reg may actually be a (PLUS (REG) +*************** copy_loop_body (copy_start, copy_end, ma +*** 1757,1760 **** +--- 1790,1794 ---- + giv_dest_reg = tem; + map->reg_map[regno] = tem; ++ record_base_value (REGNO (tem), giv_src_reg); + } + else +*************** iteration_info (iteration_var, initial_v +*** 2220,2231 **** + return; + } +! /* Reject iteration variables larger than the host long size, since they + could result in a number of iterations greater than the range of our +! `unsigned long' variable loop_n_iterations. */ +! else if (GET_MODE_BITSIZE (GET_MODE (iteration_var)) > HOST_BITS_PER_LONG) + { + if (loop_dump_stream) + fprintf (loop_dump_stream, +! "Loop unrolling: Iteration var rejected because mode larger than host long.\n"); + return; + } +--- 2254,2266 ---- + return; + } +! /* Reject iteration variables larger than the host wide int size, since they + could result in a number of iterations greater than the range of our +! `unsigned HOST_WIDE_INT' variable loop_n_iterations. */ +! else if ((GET_MODE_BITSIZE (GET_MODE (iteration_var)) +! > HOST_BITS_PER_WIDE_INT)) + { + if (loop_dump_stream) + fprintf (loop_dump_stream, +! "Loop unrolling: Iteration var rejected because mode too large.\n"); + return; + } +*************** find_splittable_regs (unroll_type, loop_ +*** 2443,2447 **** + { + rtx tem = gen_reg_rtx (bl->biv->mode); +! + emit_insn_before (gen_move_insn (tem, bl->biv->src_reg), + loop_start); +--- 2478,2483 ---- + { + rtx tem = gen_reg_rtx (bl->biv->mode); +! +! record_base_value (REGNO (tem), bl->biv->add_val); + emit_insn_before (gen_move_insn (tem, bl->biv->src_reg), + loop_start); +*************** find_splittable_regs (unroll_type, loop_ +*** 2500,2503 **** +--- 2536,2541 ---- + exits. */ + rtx tem = gen_reg_rtx (bl->biv->mode); ++ record_base_value (REGNO (tem), bl->biv->add_val); ++ + emit_insn_before (gen_move_insn (tem, bl->biv->src_reg), + loop_start); +*************** find_splittable_givs (bl, unroll_type, l +*** 2675,2678 **** +--- 2713,2717 ---- + rtx tem = gen_reg_rtx (bl->biv->mode); + ++ record_base_value (REGNO (tem), bl->biv->add_val); + emit_insn_before (gen_move_insn (tem, bl->biv->src_reg), + loop_start); +*************** find_splittable_givs (bl, unroll_type, l +*** 2716,2719 **** +--- 2755,2759 ---- + { + rtx tem = gen_reg_rtx (v->mode); ++ record_base_value (REGNO (tem), v->add_val); + emit_iv_add_mult (bl->initial_value, v->mult_val, + v->add_val, tem, loop_start); +*************** find_splittable_givs (bl, unroll_type, l +*** 2734,2747 **** + register for the split addr giv, just to be safe. */ + +! /* ??? If there are multiple address givs which have been +! combined with the same dest_reg giv, then we may only need +! one new register for them. Pulling out constants below will +! catch some of the common cases of this. Currently, I leave +! the work of simplifying multiple address givs to the +! following cse pass. */ +! +! /* As a special case, if we have multiple identical address givs +! within a single instruction, then we do use a single pseudo +! reg for both. This is necessary in case one is a match_dup + of the other. */ + +--- 2774,2780 ---- + register for the split addr giv, just to be safe. */ + +! /* If we have multiple identical address givs within a +! single instruction, then use a single pseudo reg for +! both. This is necessary in case one is a match_dup + of the other. */ + +*************** find_splittable_givs (bl, unroll_type, l +*** 2756,2759 **** +--- 2789,2812 ---- + INSN_UID (v->insn)); + } ++ /* If multiple address GIVs have been combined with the ++ same dest_reg GIV, do not create a new register for ++ each. */ ++ else if (unroll_type != UNROLL_COMPLETELY ++ && v->giv_type == DEST_ADDR ++ && v->same && v->same->giv_type == DEST_ADDR ++ && v->same->unrolled ++ #ifdef ADDRESS_COST ++ /* combine_givs_p may return true when ADDRESS_COST is ++ defined even if the multiply and add values are ++ not equal. To share a register here, the values ++ must be equal, as well as related. */ ++ && rtx_equal_p (v->mult_val, v->same->mult_val) ++ && rtx_equal_p (v->add_val, v->same->add_val) ++ #endif ++ ) ++ { ++ v->dest_reg = v->same->dest_reg; ++ v->shared = 1; ++ } + else if (unroll_type != UNROLL_COMPLETELY) + { +*************** find_splittable_givs (bl, unroll_type, l +*** 2761,2765 **** + register to hold the split value of the DEST_ADDR giv. + Emit insn to initialize its value before loop start. */ +! tem = gen_reg_rtx (v->mode); + + /* If the address giv has a constant in its new_reg value, +--- 2814,2821 ---- + register to hold the split value of the DEST_ADDR giv. + Emit insn to initialize its value before loop start. */ +! +! rtx tem = gen_reg_rtx (v->mode); +! record_base_value (REGNO (tem), v->add_val); +! v->unrolled = 1; + + /* If the address giv has a constant in its new_reg value, +*************** find_splittable_givs (bl, unroll_type, l +*** 2772,2781 **** + v->dest_reg + = plus_constant (tem, INTVAL (XEXP (v->new_reg,1))); +! + /* Only succeed if this will give valid addresses. + Try to validate both the first and the last + address resulting from loop unrolling, if + one fails, then can't do const elim here. */ +! if (! verify_addresses (v, giv_inc, unroll_number)) + { + /* Save the negative of the eliminated const, so +--- 2828,2837 ---- + v->dest_reg + = plus_constant (tem, INTVAL (XEXP (v->new_reg,1))); +! + /* Only succeed if this will give valid addresses. + Try to validate both the first and the last + address resulting from loop unrolling, if + one fails, then can't do const elim here. */ +! if (verify_addresses (v, giv_inc, unroll_number)) + { + /* Save the negative of the eliminated const, so +*************** final_biv_value (bl, loop_start, loop_en +*** 3061,3064 **** +--- 3117,3121 ---- + + tem = gen_reg_rtx (bl->biv->mode); ++ record_base_value (REGNO (tem), bl->biv->add_val); + /* Make sure loop_end is not the last insn. */ + if (NEXT_INSN (loop_end) == 0) +*************** final_giv_value (v, loop_start, loop_end +*** 3154,3157 **** +--- 3211,3215 ---- + /* Put the final biv value in tem. */ + tem = gen_reg_rtx (bl->biv->mode); ++ record_base_value (REGNO (tem), bl->biv->add_val); + emit_iv_add_mult (increment, GEN_INT (loop_n_iterations), + bl->initial_value, tem, insert_before); +diff -rcp2N gcc-2.7.2.2/varasm.c g77-new/varasm.c +*** gcc-2.7.2.2/varasm.c Thu Aug 31 19:02:53 1995 +--- g77-new/varasm.c Sun Aug 10 22:26:32 1997 +*************** assemble_variable (decl, top_level, at_e +*** 1067,1070 **** +--- 1067,1072 ---- + if (! dont_output_data) + { ++ int size; ++ + if (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST) + goto finish; +*************** assemble_variable (decl, top_level, at_e +*** 1072,1078 **** + /* This is better than explicit arithmetic, since it avoids overflow. */ + size_tree = size_binop (CEIL_DIV_EXPR, +! DECL_SIZE (decl), size_int (BITS_PER_UNIT)); + +! if (TREE_INT_CST_HIGH (size_tree) != 0) + { + error_with_decl (decl, "size of variable `%s' is too large"); +--- 1074,1082 ---- + /* This is better than explicit arithmetic, since it avoids overflow. */ + size_tree = size_binop (CEIL_DIV_EXPR, +! DECL_SIZE (decl), size_int (BITS_PER_UNIT)); + +! size = TREE_INT_CST_LOW (size_tree); +! if (TREE_INT_CST_HIGH (size_tree) != 0 +! || size != TREE_INT_CST_LOW (size_tree)) + { + error_with_decl (decl, "size of variable `%s' is too large"); +*************** decode_addr_const (exp, value) +*** 2132,2135 **** +--- 2136,2140 ---- + case COMPLEX_CST: + case CONSTRUCTOR: ++ case INTEGER_CST: + x = TREE_CST_RTL (target); + break; +*************** const_hash (exp) +*** 2247,2251 **** + return const_hash (TREE_OPERAND (exp, 0)) * 9 + + const_hash (TREE_OPERAND (exp, 1)); +! else if (code == NOP_EXPR || code == CONVERT_EXPR) + return const_hash (TREE_OPERAND (exp, 0)) * 7 + 2; + +--- 2252,2256 ---- + return const_hash (TREE_OPERAND (exp, 0)) * 9 + + const_hash (TREE_OPERAND (exp, 1)); +! else if (code == NOP_EXPR || code == CONVERT_EXPR || code == NON_LVALUE_EXPR) + return const_hash (TREE_OPERAND (exp, 0)) * 7 + 2; + +*************** compare_constant_1 (exp, p) +*** 2401,2405 **** + return p; + } +! else if (code == NOP_EXPR || code == CONVERT_EXPR) + { + p = compare_constant_1 (TREE_OPERAND (exp, 0), p); +--- 2406,2410 ---- + return p; + } +! else if (code == NOP_EXPR || code == CONVERT_EXPR || code == NON_LVALUE_EXPR) + { + p = compare_constant_1 (TREE_OPERAND (exp, 0), p); +*************** copy_constant (exp) +*** 2633,2637 **** + + case COMPLEX_CST: +! return build_complex (copy_constant (TREE_REALPART (exp)), + copy_constant (TREE_IMAGPART (exp))); + +--- 2638,2643 ---- + + case COMPLEX_CST: +! return build_complex (TREE_TYPE (exp), +! copy_constant (TREE_REALPART (exp)), + copy_constant (TREE_IMAGPART (exp))); + +*************** copy_constant (exp) +*** 2644,2647 **** +--- 2650,2654 ---- + case NOP_EXPR: + case CONVERT_EXPR: ++ case NON_LVALUE_EXPR: + return build1 (TREE_CODE (exp), TREE_TYPE (exp), + copy_constant (TREE_OPERAND (exp, 0))); +*************** output_constant_def (exp) +*** 2690,2696 **** + register rtx def; + +- if (TREE_CODE (exp) == INTEGER_CST) +- abort (); /* No TREE_CST_RTL slot in these. */ +- + if (TREE_CST_RTL (exp)) + return TREE_CST_RTL (exp); +--- 2697,2700 ---- +*************** bc_assemble_integer (exp, size) +*** 3620,3624 **** + exp = fold (exp); + +! while (TREE_CODE (exp) == NOP_EXPR || TREE_CODE (exp) == CONVERT_EXPR) + exp = TREE_OPERAND (exp, 0); + if (TREE_CODE (exp) == INTEGER_CST) +--- 3624,3629 ---- + exp = fold (exp); + +! while (TREE_CODE (exp) == NOP_EXPR || TREE_CODE (exp) == CONVERT_EXPR +! || TREE_CODE (exp) == NON_LVALUE_EXPR) + exp = TREE_OPERAND (exp, 0); + if (TREE_CODE (exp) == INTEGER_CST) +*************** bc_assemble_integer (exp, size) +*** 3631,3639 **** + const_part = TREE_OPERAND (exp, 0); + while (TREE_CODE (const_part) == NOP_EXPR +! || TREE_CODE (const_part) == CONVERT_EXPR) + const_part = TREE_OPERAND (const_part, 0); + addr_part = TREE_OPERAND (exp, 1); + while (TREE_CODE (addr_part) == NOP_EXPR +! || TREE_CODE (addr_part) == CONVERT_EXPR) + addr_part = TREE_OPERAND (addr_part, 0); + if (TREE_CODE (const_part) != INTEGER_CST) +--- 3636,3646 ---- + const_part = TREE_OPERAND (exp, 0); + while (TREE_CODE (const_part) == NOP_EXPR +! || TREE_CODE (const_part) == CONVERT_EXPR +! || TREE_CODE (const_part) == NON_LVALUE_EXPR) + const_part = TREE_OPERAND (const_part, 0); + addr_part = TREE_OPERAND (exp, 1); + while (TREE_CODE (addr_part) == NOP_EXPR +! || TREE_CODE (addr_part) == CONVERT_EXPR +! || TREE_CODE (addr_part) == NON_LVALUE_EXPR) + addr_part = TREE_OPERAND (addr_part, 0); + if (TREE_CODE (const_part) != INTEGER_CST) +diff -rcp2N gcc-2.7.2.2/version.c g77-new/version.c +*** gcc-2.7.2.2/version.c Thu Feb 20 19:24:33 1997 +--- g77-new/version.c Sun Aug 10 19:28:55 1997 +*************** +*** 1 **** +! char *version_string = "2.7.2.2"; +--- 1 ---- +! char *version_string = "2.7.2.2.f.3b"; diff --git a/gcc/f/gbe/README b/gcc/f/gbe/README new file mode 100644 index 000000000000..f03069048da5 --- /dev/null +++ b/gcc/f/gbe/README @@ -0,0 +1,45 @@ +970811 + +This directory contains .diff files for various GNU CC distributions +supported by this version of GNU Fortran. + +The name of a file includes which gcc version to which it applies. +For example, 2.7.2.2.diff is the patch file for gcc version 2.7.2.2. + +To apply a .diff file to, say, gcc 2.7.2.2, one might use the following +command (where the current directory contains the gcc source distribution +after merging into it the g77 source distribution, which would be +named gcc-2.7.2.2 in this example): + + patch -p1 -d gcc-2.7.2.2 < gcc-2.7.2.2/f/gbe/2.7.2.2.diff + + +This version of g77 is best combined with gcc versions 2.7.2.2. + +However, note that applying any of these patches does _not_ update +the gcc.info* files that constitute the Info documentation for gcc. +Therefore, after applying the patch, you must rebuild the Info +documentation yourself via: + + cd gcc; make -f Makefile.in gcc.info + +If the above command doesn't work because you don't have makeinfo +installed, you are STRONGLY encouraged to obtain the most recent +version of the GNU texinfo package (texinfo-3.11.tar.gz as of this +writing), build, and install it, then try the above command (as +makeinfo is part of texinfo). + +This distribution of g77 is not supported for versions of gcc prior +to 2.7.2.2. + +If you are using a version of gcc more recent than the most +recent .diff file's version, try the most recent .diff ONLY +if the difference is in the third field. E.g. the above +patch might work on gcc-2.7.3 or gcc-2.7.4 if these were +released. On the other hand, it probably wouldn't work for +a more major release like gcc-2.8.0 or gcc-3.0.0, and you +shouldn't try it. If the .diff file is missing, don't bother +asking for it -- it is certainly +being worked on. In the meantime, watch our progress at + for information on support +for the recent versions of gcc. diff --git a/gcc/f/glimits.j b/gcc/f/glimits.j new file mode 100644 index 000000000000..9a30bdbfba1f --- /dev/null +++ b/gcc/f/glimits.j @@ -0,0 +1,28 @@ +/* glimits.j -- Wrapper for GCC's glimits.h + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. */ + +#ifndef MAKING_DEPENDENCIES +#if !USE_HOST_LIMITS +#include "glimits.h" +#else +#include +#endif +#endif diff --git a/gcc/f/global.c b/gcc/f/global.c new file mode 100644 index 000000000000..033448deaa42 --- /dev/null +++ b/gcc/f/global.c @@ -0,0 +1,1490 @@ +/* global.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + + Description: + Manages information kept across individual program units within a single + source file. This includes reporting errors when a name is defined + multiple times (for example, two program units named FOO) and when a + COMMON block is given initial data in more than one program unit. + + Modifications: +*/ + +/* Include files. */ + +#include "proj.h" +#include "global.h" +#include "info.h" +#include "lex.h" +#include "malloc.h" +#include "name.h" +#include "symbol.h" +#include "top.h" + +/* Externals defined here. */ + + +/* Simple definitions and enumerations. */ + + +/* Internal typedefs. */ + + +/* Private include files. */ + + +/* Internal structure definitions. */ + + +/* Static objects accessed by functions in this module. */ + +#if FFEGLOBAL_ENABLED +static ffenameSpace ffeglobal_filewide_ = NULL; +static char *ffeglobal_type_string_[] = +{ + [FFEGLOBAL_typeNONE] "??", + [FFEGLOBAL_typeMAIN] "main program", + [FFEGLOBAL_typeEXT] "external", + [FFEGLOBAL_typeSUBR] "subroutine", + [FFEGLOBAL_typeFUNC] "function", + [FFEGLOBAL_typeBDATA] "block data", + [FFEGLOBAL_typeCOMMON] "common block", + [FFEGLOBAL_typeANY] "?any?" +}; +#endif + +/* Static functions (internal). */ + + +/* Internal macros. */ + + +/* Call given fn with all globals + + ffeglobal (*fn)(ffeglobal g); + ffeglobal_drive(fn); */ + +#if FFEGLOBAL_ENABLED +void +ffeglobal_drive (ffeglobal (*fn) ()) +{ + if (ffeglobal_filewide_ != NULL) + ffename_space_drive_global (ffeglobal_filewide_, fn); +} + +#endif +/* ffeglobal_new_ -- Make new global + + ffename n; + ffeglobal g; + g = ffeglobal_new_(n); */ + +#if FFEGLOBAL_ENABLED +static ffeglobal +ffeglobal_new_ (ffename n) +{ + ffeglobal g; + + assert (n != NULL); + + g = (ffeglobal) malloc_new_ks (malloc_pool_image (), "FFEGLOBAL", + sizeof (*g)); + g->n = n; +#ifdef FFECOM_globalHOOK + g->hook = FFECOM_globalNULL; +#endif + g->tick = 0; + + ffename_set_global (n, g); + + return g; +} + +#endif +/* ffeglobal_init_1 -- Initialize per file + + ffeglobal_init_1(); */ + +void +ffeglobal_init_1 () +{ +#if FFEGLOBAL_ENABLED + if (ffeglobal_filewide_ != NULL) + ffename_space_kill (ffeglobal_filewide_); + ffeglobal_filewide_ = ffename_space_new (malloc_pool_image ()); +#endif +} + +/* ffeglobal_init_common -- Initial value specified for common block + + ffesymbol s; // the ffesymbol for the common block + ffelexToken t; // the token with the point of initialization + ffeglobal_init_common(s,t); + + For back ends where file-wide global symbols are not maintained, does + nothing. Otherwise, makes sure this common block hasn't already been + initialized in a previous program unit, and flag that it's been + initialized in this one. */ + +void +ffeglobal_init_common (ffesymbol s, ffelexToken t) +{ +#if FFEGLOBAL_ENABLED + ffeglobal g; + + g = ffesymbol_global (s); + + if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON)) + return; + if (g->type == FFEGLOBAL_typeANY) + return; + + if (g->tick == ffe_count_2) + return; + + if (g->tick != 0) + { + if (g->u.common.initt != NULL) + { + ffebad_start (FFEBAD_COMMON_ALREADY_INIT); + ffebad_string (ffesymbol_text (s)); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (g->u.common.initt), + ffelex_token_where_column (g->u.common.initt)); + ffebad_finish (); + } + + /* Complain about just one attempt to reinit per program unit, but + continue referring back to the first such successful attempt. */ + } + else + { + if (g->u.common.blank) + { + ffebad_start (FFEBAD_COMMON_BLANK_INIT); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + + g->u.common.initt = ffelex_token_use (t); + } + + g->tick = ffe_count_2; +#endif +} + +/* ffeglobal_new_common -- New common block + + ffesymbol s; // the ffesymbol for the new common block + ffelexToken t; // the token with the name of the common block + bool blank; // TRUE if blank common + ffeglobal_new_common(s,t,blank); + + For back ends where file-wide global symbols are not maintained, does + nothing. Otherwise, makes sure this symbol hasn't been seen before or + is known as a common block. */ + +void +ffeglobal_new_common (ffesymbol s, ffelexToken t, bool blank) +{ +#if FFEGLOBAL_ENABLED + ffename n; + ffeglobal g; + + if (ffesymbol_global (s) == NULL) + { + n = ffename_find (ffeglobal_filewide_, t); + g = ffename_global (n); + } + else + { + g = ffesymbol_global (s); + n = NULL; + } + + if ((g != NULL) && (g->type == FFEGLOBAL_typeANY)) + return; + + if ((g != NULL) && (g->type != FFEGLOBAL_typeNONE)) + { + if (g->type == FFEGLOBAL_typeCOMMON) + { + assert (g->u.common.blank == blank); + } + else + { + if (ffe_is_globals () || ffe_is_warn_globals ()) + { + ffebad_start (ffe_is_globals () + ? FFEBAD_FILEWIDE_ALREADY_SEEN + : FFEBAD_FILEWIDE_ALREADY_SEEN_W); + ffebad_string (ffelex_token_text (t)); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (g->t), + ffelex_token_where_column (g->t)); + ffebad_finish (); + } + g->type = FFEGLOBAL_typeANY; + } + } + else + { + if (g == NULL) + { + g = ffeglobal_new_ (n); + g->intrinsic = FALSE; + } + else if (g->intrinsic + && !g->explicit_intrinsic + && ffe_is_warn_globals ()) + { + ffebad_start (FFEBAD_INTRINSIC_GLOBAL); + ffebad_string (ffelex_token_text (t)); + ffebad_string ("common block"); + ffebad_string ("intrinsic"); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (g->t), + ffelex_token_where_column (g->t)); + ffebad_finish (); + } + g->t = ffelex_token_use (t); + g->type = FFEGLOBAL_typeCOMMON; + g->u.common.have_pad = FALSE; + g->u.common.have_save = FALSE; + g->u.common.have_size = FALSE; + g->u.common.blank = blank; + } + + ffesymbol_set_global (s, g); +#endif +} + +/* ffeglobal_new_progunit_ -- New program unit + + ffesymbol s; // the ffesymbol for the new unit + ffelexToken t; // the token with the name of the unit + ffeglobalType type; // the type of the new unit + ffeglobal_new_progunit_(s,t,type); + + For back ends where file-wide global symbols are not maintained, does + nothing. Otherwise, makes sure this symbol hasn't been seen before. */ + +void +ffeglobal_new_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type) +{ +#if FFEGLOBAL_ENABLED + ffename n; + ffeglobal g; + + n = ffename_find (ffeglobal_filewide_, t); + g = ffename_global (n); + if ((g != NULL) && (g->type == FFEGLOBAL_typeANY)) + return; + + if ((g != NULL) + && (g->type != FFEGLOBAL_typeNONE) + && (g->type != FFEGLOBAL_typeEXT) + && ((g->type != type) + || (g->u.proc.defined))) + { + if (ffe_is_globals () || ffe_is_warn_globals ()) + { + ffebad_start (ffe_is_globals () + ? FFEBAD_FILEWIDE_ALREADY_SEEN + : FFEBAD_FILEWIDE_ALREADY_SEEN_W); + ffebad_string (ffelex_token_text (t)); + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (g->t), + ffelex_token_where_column (g->t)); + ffebad_finish (); + } + g->type = FFEGLOBAL_typeANY; + } + else + { + if (g == NULL) + { + g = ffeglobal_new_ (n); + g->intrinsic = FALSE; + g->u.proc.n_args = -1; + g->u.proc.other_t = NULL; + } + else if ((ffesymbol_basictype (s) != FFEINFO_basictypeNONE) + && ((ffesymbol_basictype (s) != g->u.proc.bt) + || (ffesymbol_kindtype (s) != g->u.proc.kt) + || ((ffesymbol_size (s) != FFETARGET_charactersizeNONE) + && (ffesymbol_size (s) != g->u.proc.sz)))) + { + if (ffe_is_globals () || ffe_is_warn_globals ()) + { + ffebad_start (ffe_is_globals () + ? FFEBAD_FILEWIDE_TYPE_MISMATCH + : FFEBAD_FILEWIDE_TYPE_MISMATCH_W); + ffebad_string (ffelex_token_text (t)); + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (g->t), + ffelex_token_where_column (g->t)); + ffebad_finish (); + } + g->type = FFEGLOBAL_typeANY; + return; + } + if (g->intrinsic + && !g->explicit_intrinsic + && ffe_is_warn_globals ()) + { + ffebad_start (FFEBAD_INTRINSIC_GLOBAL); + ffebad_string (ffelex_token_text (t)); + ffebad_string ("global"); + ffebad_string ("intrinsic"); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (g->t), + ffelex_token_where_column (g->t)); + ffebad_finish (); + } + g->t = ffelex_token_use (t); + if ((g->tick == 0) + || (g->u.proc.bt == FFEINFO_basictypeNONE) + || (g->u.proc.kt == FFEINFO_kindtypeNONE)) + { + g->u.proc.bt = ffesymbol_basictype (s); + g->u.proc.kt = ffesymbol_kindtype (s); + g->u.proc.sz = ffesymbol_size (s); + } + g->tick = ffe_count_2; + if ((g->tick != 0) + && (g->type != type)) + g->u.proc.n_args = -1; + g->type = type; + g->u.proc.defined = TRUE; + } + + ffesymbol_set_global (s, g); +#endif +} + +/* ffeglobal_pad_common -- Check initial padding of common area + + ffesymbol s; // the common area + ffetargetAlign pad; // the initial padding + ffeglobal_pad_common(s,pad,ffesymbol_where_line(s), + ffesymbol_where_column(s)); + + In global-enabled mode, make sure the padding agrees with any existing + padding established for the common area, otherwise complain. + In global-disabled mode, warn about nonzero padding. */ + +void +ffeglobal_pad_common (ffesymbol s, ffetargetAlign pad, ffewhereLine wl, + ffewhereColumn wc) +{ +#if FFEGLOBAL_ENABLED + ffeglobal g; + + g = ffesymbol_global (s); + if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON)) + return; /* Let someone else catch this! */ + if (g->type == FFEGLOBAL_typeANY) + return; + + if (!g->u.common.have_pad) + { + g->u.common.have_pad = TRUE; + g->u.common.pad = pad; + g->u.common.pad_where_line = ffewhere_line_use (wl); + g->u.common.pad_where_col = ffewhere_column_use (wc); + } + else + { + if (g->u.common.pad != pad) + { + char padding_1[20]; + char padding_2[20]; + + sprintf (&padding_1[0], "%" ffetargetAlign_f "u", pad); + sprintf (&padding_2[0], "%" ffetargetAlign_f "u", g->u.common.pad); + ffebad_start (FFEBAD_COMMON_DIFF_PAD); + ffebad_string (ffesymbol_text (s)); + ffebad_string (padding_1); + ffebad_here (0, wl, wc); + ffebad_string (padding_2); + ffebad_string ((pad == 1) + ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS); + ffebad_string ((g->u.common.pad == 1) + ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS); + ffebad_here (1, g->u.common.pad_where_line, g->u.common.pad_where_col); + ffebad_finish (); + } + } +#endif + + if (pad != 0) + { /* Warn about initial padding in common area. */ + char padding[20]; + + sprintf (&padding[0], "%" ffetargetAlign_f "u", pad); + ffebad_start (FFEBAD_COMMON_INIT_PAD); + ffebad_string (ffesymbol_text (s)); + ffebad_string (padding); + ffebad_string ((pad == 1) + ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS); + ffebad_here (0, wl, wc); + ffebad_finish (); + } +} + +/* Collect info for a global's argument. */ + +void +ffeglobal_proc_def_arg (ffesymbol s, int argno, char *name, ffeglobalArgSummary as, + ffeinfoBasictype bt, ffeinfoKindtype kt, + bool array) +{ + ffeglobal g = ffesymbol_global (s); + ffeglobalArgInfo_ ai; + + assert (g != NULL); + + if (g->type == FFEGLOBAL_typeANY) + return; + + assert (g->u.proc.n_args >= 0); + + if (argno >= g->u.proc.n_args) + return; /* Already complained about this discrepancy. */ + + ai = &g->u.proc.arg_info[argno]; + + /* Maybe warn about previous references. */ + + if ((ai->t != NULL) + && ffe_is_warn_globals ()) + { + char *refwhy = NULL; + char *defwhy = NULL; + bool warn = FALSE; + + switch (as) + { + case FFEGLOBAL_argsummaryREF: + if ((ai->as != FFEGLOBAL_argsummaryREF) + && (ai->as != FFEGLOBAL_argsummaryNONE) + && ((ai->as != FFEGLOBAL_argsummaryDESCR) /* Choose better message. */ + || (ai->bt != FFEINFO_basictypeCHARACTER) + || (ai->bt == bt))) + { + warn = TRUE; + refwhy = "passed by reference"; + } + break; + + case FFEGLOBAL_argsummaryDESCR: + if ((ai->as != FFEGLOBAL_argsummaryDESCR) + && (ai->as != FFEGLOBAL_argsummaryNONE) + && ((ai->as != FFEGLOBAL_argsummaryREF) /* Choose better message. */ + || (bt != FFEINFO_basictypeCHARACTER) + || (ai->bt == bt))) + { + warn = TRUE; + refwhy = "passed by descriptor"; + } + break; + + case FFEGLOBAL_argsummaryPROC: + if ((ai->as != FFEGLOBAL_argsummaryPROC) + && (ai->as != FFEGLOBAL_argsummarySUBR) + && (ai->as != FFEGLOBAL_argsummaryFUNC) + && (ai->as != FFEGLOBAL_argsummaryNONE)) + { + warn = TRUE; + refwhy = "a procedure"; + } + break; + + case FFEGLOBAL_argsummarySUBR: + if ((ai->as != FFEGLOBAL_argsummaryPROC) + && (ai->as != FFEGLOBAL_argsummarySUBR) + && (ai->as != FFEGLOBAL_argsummaryNONE)) + { + warn = TRUE; + refwhy = "a subroutine"; + } + break; + + case FFEGLOBAL_argsummaryFUNC: + if ((ai->as != FFEGLOBAL_argsummaryPROC) + && (ai->as != FFEGLOBAL_argsummaryFUNC) + && (ai->as != FFEGLOBAL_argsummaryNONE)) + { + warn = TRUE; + refwhy = "a function"; + } + break; + + case FFEGLOBAL_argsummaryALTRTN: + if ((ai->as != FFEGLOBAL_argsummaryALTRTN) + && (ai->as != FFEGLOBAL_argsummaryNONE)) + { + warn = TRUE; + refwhy = "an alternate-return label"; + } + break; + + default: + break; + } + + if ((refwhy != NULL) && (defwhy == NULL)) + { + /* Fill in the def info. */ + + switch (ai->as) + { + case FFEGLOBAL_argsummaryNONE: + defwhy = "omitted"; + break; + + case FFEGLOBAL_argsummaryVAL: + defwhy = "passed by value"; + break; + + case FFEGLOBAL_argsummaryREF: + defwhy = "passed by reference"; + break; + + case FFEGLOBAL_argsummaryDESCR: + defwhy = "passed by descriptor"; + break; + + case FFEGLOBAL_argsummaryPROC: + defwhy = "a procedure"; + break; + + case FFEGLOBAL_argsummarySUBR: + defwhy = "a subroutine"; + break; + + case FFEGLOBAL_argsummaryFUNC: + defwhy = "a function"; + break; + + case FFEGLOBAL_argsummaryALTRTN: + defwhy = "an alternate-return label"; + break; + + case FFEGLOBAL_argsummaryPTR: + defwhy = "a pointer"; + break; + + default: + defwhy = "???"; + break; + } + } + + if (!warn + && (bt != FFEINFO_basictypeHOLLERITH) + && (bt != FFEINFO_basictypeTYPELESS) + && (bt != FFEINFO_basictypeNONE) + && (ai->bt != FFEINFO_basictypeHOLLERITH) + && (ai->bt != FFEINFO_basictypeTYPELESS) + && (ai->bt != FFEINFO_basictypeNONE)) + { + /* Check types. */ + + if ((bt != ai->bt) + && ((bt != FFEINFO_basictypeREAL) + || (ai->bt != FFEINFO_basictypeCOMPLEX)) + && ((bt != FFEINFO_basictypeCOMPLEX) + || (ai->bt != FFEINFO_basictypeREAL))) + { + warn = TRUE; /* We can cope with these differences. */ + refwhy = "one type"; + defwhy = "some other type"; + } + + if (!warn && (kt != ai->kt)) + { + warn = TRUE; + refwhy = "one precision"; + defwhy = "some other precision"; + } + } + + if (warn) + { + char num[60]; + + if (name == NULL) + sprintf (&num[0], "%d", argno + 1); + else + { + if (strlen (name) < 30) + sprintf (&num[0], "%d (named `%s')", argno + 1, name); + else + sprintf (&num[0], "%d (named `%.*s...')", argno + 1, 30, name); + } + ffebad_start (FFEBAD_FILEWIDE_ARG_W); + ffebad_string (ffesymbol_text (s)); + ffebad_string (num); + ffebad_string (refwhy); + ffebad_string (defwhy); + ffebad_here (0, ffelex_token_where_line (g->t), ffelex_token_where_column (g->t)); + ffebad_here (1, ffelex_token_where_line (ai->t), ffelex_token_where_column (ai->t)); + ffebad_finish (); + } + } + + /* Define this argument. */ + + if (ai->t != NULL) + ffelex_token_kill (ai->t); + if ((as != FFEGLOBAL_argsummaryPROC) + || (ai->t == NULL)) + ai->as = as; /* Otherwise leave SUBR/FUNC info intact. */ + ai->t = ffelex_token_use (g->t); + if (name == NULL) + ai->name = NULL; + else + { + ai->name = malloc_new_ks (malloc_pool_image (), + "ffeglobalArgInfo_ name", + strlen (name) + 1); + strcpy (ai->name, name); + } + ai->bt = bt; + ai->kt = kt; + ai->array = array; +} + +/* Collect info on #args a global accepts. */ + +void +ffeglobal_proc_def_nargs (ffesymbol s, int n_args) +{ + ffeglobal g = ffesymbol_global (s); + + assert (g != NULL); + + if (g->type == FFEGLOBAL_typeANY) + return; + + if (g->u.proc.n_args >= 0) + { + if (g->u.proc.n_args == n_args) + return; + + if (ffe_is_warn_globals ()) + { + ffebad_start (FFEBAD_FILEWIDE_NARGS_W); + ffebad_string (ffesymbol_text (s)); + if (g->u.proc.n_args > n_args) + ffebad_string ("few"); + else + ffebad_string ("many"); + ffebad_here (0, ffelex_token_where_line (g->u.proc.other_t), + ffelex_token_where_column (g->u.proc.other_t)); + ffebad_here (1, ffelex_token_where_line (g->t), + ffelex_token_where_column (g->t)); + ffebad_finish (); + } + } + + /* This is new info we can use in cross-checking future references + and a possible future definition. */ + + g->u.proc.n_args = n_args; + g->u.proc.other_t = NULL; /* No other reference yet. */ + + if (n_args == 0) + { + g->u.proc.arg_info = NULL; + return; + } + + g->u.proc.arg_info + = (ffeglobalArgInfo_) malloc_new_ks (malloc_pool_image (), + "ffeglobalArgInfo_", + n_args * sizeof (g->u.proc.arg_info[0])); + while (n_args-- > 0) + g->u.proc.arg_info[n_args].t = NULL; +} + +/* Verify that the info for a global's argument is valid. */ + +bool +ffeglobal_proc_ref_arg (ffesymbol s, int argno, ffeglobalArgSummary as, + ffeinfoBasictype bt, ffeinfoKindtype kt, + bool array, ffelexToken t) +{ + ffeglobal g = ffesymbol_global (s); + ffeglobalArgInfo_ ai; + + assert (g != NULL); + + if (g->type == FFEGLOBAL_typeANY) + return FALSE; + + assert (g->u.proc.n_args >= 0); + + if (argno >= g->u.proc.n_args) + return TRUE; /* Already complained about this discrepancy. */ + + ai = &g->u.proc.arg_info[argno]; + + /* Warn about previous references. */ + + if (ai->t != NULL) + { + char *refwhy = NULL; + char *defwhy = NULL; + bool fail = FALSE; + bool warn = FALSE; + + switch (as) + { + case FFEGLOBAL_argsummaryNONE: + if (g->u.proc.defined) + { + fail = TRUE; + refwhy = "omitted"; + defwhy = "not optional"; + } + break; + + case FFEGLOBAL_argsummaryVAL: + if (ai->as != FFEGLOBAL_argsummaryVAL) + { + fail = TRUE; + refwhy = "passed by value"; + } + break; + + case FFEGLOBAL_argsummaryREF: + if ((ai->as != FFEGLOBAL_argsummaryREF) + && (ai->as != FFEGLOBAL_argsummaryNONE) + && ((ai->as != FFEGLOBAL_argsummaryDESCR) /* Choose better message. */ + || (ai->bt != FFEINFO_basictypeCHARACTER) + || (ai->bt == bt))) + { + fail = TRUE; + refwhy = "passed by reference"; + } + break; + + case FFEGLOBAL_argsummaryDESCR: + if ((ai->as != FFEGLOBAL_argsummaryDESCR) + && (ai->as != FFEGLOBAL_argsummaryNONE) + && ((ai->as != FFEGLOBAL_argsummaryREF) /* Choose better message. */ + || (bt != FFEINFO_basictypeCHARACTER) + || (ai->bt == bt))) + { + fail = TRUE; + refwhy = "passed by descriptor"; + } + break; + + case FFEGLOBAL_argsummaryPROC: + if ((ai->as != FFEGLOBAL_argsummaryPROC) + && (ai->as != FFEGLOBAL_argsummarySUBR) + && (ai->as != FFEGLOBAL_argsummaryFUNC) + && (ai->as != FFEGLOBAL_argsummaryNONE)) + { + fail = TRUE; + refwhy = "a procedure"; + } + break; + + case FFEGLOBAL_argsummarySUBR: + if ((ai->as != FFEGLOBAL_argsummaryPROC) + && (ai->as != FFEGLOBAL_argsummarySUBR) + && (ai->as != FFEGLOBAL_argsummaryNONE)) + { + fail = TRUE; + refwhy = "a subroutine"; + } + break; + + case FFEGLOBAL_argsummaryFUNC: + if ((ai->as != FFEGLOBAL_argsummaryPROC) + && (ai->as != FFEGLOBAL_argsummaryFUNC) + && (ai->as != FFEGLOBAL_argsummaryNONE)) + { + fail = TRUE; + refwhy = "a function"; + } + break; + + case FFEGLOBAL_argsummaryALTRTN: + if ((ai->as != FFEGLOBAL_argsummaryALTRTN) + && (ai->as != FFEGLOBAL_argsummaryNONE)) + { + fail = TRUE; + refwhy = "an alternate-return label"; + } + break; + + case FFEGLOBAL_argsummaryPTR: + if ((ai->as != FFEGLOBAL_argsummaryPTR) + && (ai->as != FFEGLOBAL_argsummaryNONE)) + { + fail = TRUE; + refwhy = "a pointer"; + } + break; + + default: + break; + } + + if ((refwhy != NULL) && (defwhy == NULL)) + { + /* Fill in the def info. */ + + switch (ai->as) + { + case FFEGLOBAL_argsummaryNONE: + defwhy = "omitted"; + break; + + case FFEGLOBAL_argsummaryVAL: + defwhy = "passed by value"; + break; + + case FFEGLOBAL_argsummaryREF: + defwhy = "passed by reference"; + break; + + case FFEGLOBAL_argsummaryDESCR: + defwhy = "passed by descriptor"; + break; + + case FFEGLOBAL_argsummaryPROC: + defwhy = "a procedure"; + break; + + case FFEGLOBAL_argsummarySUBR: + defwhy = "a subroutine"; + break; + + case FFEGLOBAL_argsummaryFUNC: + defwhy = "a function"; + break; + + case FFEGLOBAL_argsummaryALTRTN: + defwhy = "an alternate-return label"; + break; + + case FFEGLOBAL_argsummaryPTR: + defwhy = "a pointer"; + break; + + default: + defwhy = "???"; + break; + } + } + + if (!fail && !warn + && (bt != FFEINFO_basictypeHOLLERITH) + && (bt != FFEINFO_basictypeTYPELESS) + && (bt != FFEINFO_basictypeNONE) + && (ai->bt != FFEINFO_basictypeHOLLERITH) + && (ai->bt != FFEINFO_basictypeNONE) + && (ai->bt != FFEINFO_basictypeTYPELESS)) + { + /* Check types. */ + + if ((bt != ai->bt) + && ((bt != FFEINFO_basictypeREAL) + || (ai->bt != FFEINFO_basictypeCOMPLEX)) + && ((bt != FFEINFO_basictypeCOMPLEX) + || (ai->bt != FFEINFO_basictypeREAL))) + { + if (((bt == FFEINFO_basictypeINTEGER) + && (ai->bt == FFEINFO_basictypeLOGICAL)) + || ((bt == FFEINFO_basictypeLOGICAL) + && (ai->bt == FFEINFO_basictypeINTEGER))) + warn = TRUE; /* We can cope with these differences. */ + else + fail = TRUE; + refwhy = "one type"; + defwhy = "some other type"; + } + + if (!fail && !warn && (kt != ai->kt)) + { + fail = TRUE; + refwhy = "one precision"; + defwhy = "some other precision"; + } + } + + if (fail && ! g->u.proc.defined) + { + /* No point failing if we're worried only about invocations. */ + fail = FALSE; + warn = TRUE; + } + + if (fail && ! ffe_is_globals ()) + { + warn = TRUE; + fail = FALSE; + } + + if (fail || (warn && ffe_is_warn_globals ())) + { + char num[60]; + + if (ai->name == NULL) + sprintf (&num[0], "%d", argno + 1); + else + { + if (strlen (ai->name) < 30) + sprintf (&num[0], "%d (named `%s')", argno + 1, ai->name); + else + sprintf (&num[0], "%d (named `%.*s...')", argno + 1, 30, ai->name); + } + ffebad_start (fail ? FFEBAD_FILEWIDE_ARG : FFEBAD_FILEWIDE_ARG_W); + ffebad_string (ffesymbol_text (s)); + ffebad_string (num); + ffebad_string (refwhy); + ffebad_string (defwhy); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (ai->t), ffelex_token_where_column (ai->t)); + ffebad_finish (); + return (fail ? FALSE : TRUE); + } + + if (warn) + return TRUE; + } + + /* Define this argument. */ + + if (ai->t != NULL) + ffelex_token_kill (ai->t); + if ((as != FFEGLOBAL_argsummaryPROC) + || (ai->t == NULL)) + ai->as = as; + ai->t = ffelex_token_use (g->t); + ai->name = NULL; + ai->bt = bt; + ai->kt = kt; + ai->array = array; + return TRUE; +} + +bool +ffeglobal_proc_ref_nargs (ffesymbol s, int n_args, ffelexToken t) +{ + ffeglobal g = ffesymbol_global (s); + + assert (g != NULL); + + if (g->type == FFEGLOBAL_typeANY) + return FALSE; + + if (g->u.proc.n_args >= 0) + { + if (g->u.proc.n_args == n_args) + return TRUE; + + if (g->u.proc.defined && ffe_is_globals ()) + { + ffebad_start (FFEBAD_FILEWIDE_NARGS); + ffebad_string (ffesymbol_text (s)); + if (g->u.proc.n_args > n_args) + ffebad_string ("few"); + else + ffebad_string ("many"); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (g->t), + ffelex_token_where_column (g->t)); + ffebad_finish (); + return FALSE; + } + + if (ffe_is_warn_globals ()) + { + ffebad_start (FFEBAD_FILEWIDE_NARGS_W); + ffebad_string (ffesymbol_text (s)); + if (g->u.proc.n_args > n_args) + ffebad_string ("few"); + else + ffebad_string ("many"); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (g->t), + ffelex_token_where_column (g->t)); + ffebad_finish (); + } + + return TRUE; /* Don't replace the info we already have. */ + } + + /* This is new info we can use in cross-checking future references + and a possible future definition. */ + + g->u.proc.n_args = n_args; + g->u.proc.other_t = ffelex_token_use (t); + + /* Make this "the" place we found the global, since it has the most info. */ + + if (g->t != NULL) + ffelex_token_kill (g->t); + g->t = ffelex_token_use (t); + + if (n_args == 0) + { + g->u.proc.arg_info = NULL; + return TRUE; + } + + g->u.proc.arg_info + = (ffeglobalArgInfo_) malloc_new_ks (malloc_pool_image (), + "ffeglobalArgInfo_", + n_args * sizeof (g->u.proc.arg_info[0])); + while (n_args-- > 0) + g->u.proc.arg_info[n_args].t = NULL; + + return TRUE; +} + +/* Return a global for a promoted symbol (one that has heretofore + been assumed to be local, but since discovered to be global). */ + +ffeglobal +ffeglobal_promoted (ffesymbol s) +{ +#if FFEGLOBAL_ENABLED + ffename n; + ffeglobal g; + + assert (ffesymbol_global (s) == NULL); + + n = ffename_find (ffeglobal_filewide_, ffename_token (ffesymbol_name (s))); + g = ffename_global (n); + + return g; +#else + return NULL; +#endif +} + +/* Register a reference to an intrinsic. Such a reference is always + valid, though a warning might be in order if the same name has + already been used for a global. */ + +void +ffeglobal_ref_intrinsic (ffesymbol s, ffelexToken t, bool explicit) +{ +#if FFEGLOBAL_ENABLED + ffename n; + ffeglobal g; + + if (ffesymbol_global (s) == NULL) + { + n = ffename_find (ffeglobal_filewide_, t); + g = ffename_global (n); + } + else + { + g = ffesymbol_global (s); + n = NULL; + } + + if ((g != NULL) && (g->type == FFEGLOBAL_typeANY)) + return; + + if ((g != NULL) && (g->type != FFEGLOBAL_typeNONE)) + { + if (! explicit + && ! g->intrinsic + && ffe_is_warn_globals ()) + { + ffebad_start (FFEBAD_INTRINSIC_GLOBAL); + ffebad_string (ffelex_token_text (t)); + ffebad_string ("intrinsic"); + ffebad_string ("global"); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (g->t), + ffelex_token_where_column (g->t)); + ffebad_finish (); + } + } + else + { + if (g == NULL) + { + g = ffeglobal_new_ (n); + g->tick = ffe_count_2; + g->type = FFEGLOBAL_typeNONE; + g->intrinsic = TRUE; + g->explicit_intrinsic = explicit; + g->t = ffelex_token_use (t); + } + else if (g->intrinsic + && (explicit != g->explicit_intrinsic) + && (g->tick != ffe_count_2) + && ffe_is_warn_globals ()) + { + ffebad_start (FFEBAD_INTRINSIC_EXPIMP); + ffebad_string (ffelex_token_text (t)); + ffebad_string (explicit ? "explicit" : "implicit"); + ffebad_string (explicit ? "implicit" : "explicit"); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (g->t), + ffelex_token_where_column (g->t)); + ffebad_finish (); + } + } + + g->intrinsic = TRUE; + if (explicit) + g->explicit_intrinsic = TRUE; + + ffesymbol_set_global (s, g); +#endif +} + +/* Register a reference to a global. Returns TRUE if the reference + is valid. */ + +bool +ffeglobal_ref_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type) +{ +#if FFEGLOBAL_ENABLED + ffename n = NULL; + ffeglobal g; + + g = ffesymbol_global (s); + if (g == NULL) + { + n = ffename_find (ffeglobal_filewide_, t); + g = ffename_global (n); + if (g != NULL) + ffesymbol_set_global (s, g); + } + + if ((g != NULL) && (g->type == FFEGLOBAL_typeANY)) + return TRUE; + + if ((g != NULL) + && (g->type != FFEGLOBAL_typeNONE) + && (g->type != type) + && (g->type != FFEGLOBAL_typeEXT) + && (type != FFEGLOBAL_typeEXT)) + { + if ((((type == FFEGLOBAL_typeBDATA) + && (g->type != FFEGLOBAL_typeCOMMON)) + || ((g->type == FFEGLOBAL_typeBDATA) + && (type != FFEGLOBAL_typeCOMMON) + && ! g->u.proc.defined))) + { +#if 0 /* This is likely to just annoy people. */ + if (ffe_is_warn_globals ()) + { + ffebad_start (FFEBAD_FILEWIDE_TIFF); + ffebad_string (ffelex_token_text (t)); + ffebad_string (ffeglobal_type_string_[type]); + ffebad_string (ffeglobal_type_string_[g->type]); + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (g->t), + ffelex_token_where_column (g->t)); + ffebad_finish (); + } +#endif + /* It is never really _known_ that an EXTERNAL statement + names a BLOCK DATA by just looking at the program unit, + so don't override a different notion. */ + if (type == FFEGLOBAL_typeBDATA) + type = FFEGLOBAL_typeEXT; + } + else if (ffe_is_globals ()) + { + ffebad_start (FFEBAD_FILEWIDE_DISAGREEMENT); + ffebad_string (ffelex_token_text (t)); + ffebad_string (ffeglobal_type_string_[type]); + ffebad_string (ffeglobal_type_string_[g->type]); + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (g->t), + ffelex_token_where_column (g->t)); + ffebad_finish (); + g->type = FFEGLOBAL_typeANY; + return FALSE; + } + else if (ffe_is_warn_globals ()) + { + ffebad_start (FFEBAD_FILEWIDE_DISAGREEMENT_W); + ffebad_string (ffelex_token_text (t)); + ffebad_string (ffeglobal_type_string_[type]); + ffebad_string (ffeglobal_type_string_[g->type]); + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (g->t), + ffelex_token_where_column (g->t)); + ffebad_finish (); + g->type = FFEGLOBAL_typeANY; + return TRUE; + } + } + + if ((g != NULL) + && (type == FFEGLOBAL_typeFUNC)) + { + /* If just filling in this function's type, do so. */ + if ((g->tick == ffe_count_2) + && (ffesymbol_basictype (s) != FFEINFO_basictypeNONE) + && (ffesymbol_kindtype (s) != FFEINFO_kindtypeNONE)) + { + g->u.proc.bt = ffesymbol_basictype (s); + g->u.proc.kt = ffesymbol_kindtype (s); + g->u.proc.sz = ffesymbol_size (s); + } + /* Else, make sure there is type agreement. */ + else if ((g->u.proc.bt != FFEINFO_basictypeNONE) + && (ffesymbol_basictype (s) != FFEINFO_basictypeNONE) + && ((ffesymbol_basictype (s) != g->u.proc.bt) + || (ffesymbol_kindtype (s) != g->u.proc.kt) + || ((ffesymbol_size (s) != g->u.proc.sz) + && (g->u.proc.sz != FFETARGET_charactersizeNONE)))) + { + if (ffe_is_globals ()) + { + ffebad_start (FFEBAD_FILEWIDE_TYPE_MISMATCH); + ffebad_string (ffelex_token_text (t)); + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (g->t), + ffelex_token_where_column (g->t)); + ffebad_finish (); + g->type = FFEGLOBAL_typeANY; + return FALSE; + } + if (ffe_is_warn_globals ()) + { + ffebad_start (FFEBAD_FILEWIDE_TYPE_MISMATCH_W); + ffebad_string (ffelex_token_text (t)); + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (g->t), + ffelex_token_where_column (g->t)); + ffebad_finish (); + } + g->type = FFEGLOBAL_typeANY; + return TRUE; + } + } + + if (g == NULL) + { + g = ffeglobal_new_ (n); + g->t = ffelex_token_use (t); + g->tick = ffe_count_2; + g->intrinsic = FALSE; + g->type = type; + g->u.proc.defined = FALSE; + g->u.proc.bt = ffesymbol_basictype (s); + g->u.proc.kt = ffesymbol_kindtype (s); + g->u.proc.sz = ffesymbol_size (s); + g->u.proc.n_args = -1; + ffesymbol_set_global (s, g); + } + else if (g->intrinsic + && !g->explicit_intrinsic + && (g->tick != ffe_count_2) + && ffe_is_warn_globals ()) + { + ffebad_start (FFEBAD_INTRINSIC_GLOBAL); + ffebad_string (ffelex_token_text (t)); + ffebad_string ("global"); + ffebad_string ("intrinsic"); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_here (1, ffelex_token_where_line (g->t), + ffelex_token_where_column (g->t)); + ffebad_finish (); + } + + if ((g->type != type) + && (type != FFEGLOBAL_typeEXT)) + { + /* We've learned more, so point to where we learned it. */ + g->t = ffelex_token_use (t); + g->type = type; + g->u.proc.n_args = -1; + } + + return TRUE; +#endif +} + +/* ffeglobal_save_common -- Check SAVE status of common area + + ffesymbol s; // the common area + bool save; // TRUE if SAVEd, FALSE otherwise + ffeglobal_save_common(s,save,ffesymbol_where_line(s), + ffesymbol_where_column(s)); + + In global-enabled mode, make sure the save info agrees with any existing + info established for the common area, otherwise complain. + In global-disabled mode, do nothing. */ + +void +ffeglobal_save_common (ffesymbol s, bool save, ffewhereLine wl, + ffewhereColumn wc) +{ +#if FFEGLOBAL_ENABLED + ffeglobal g; + + g = ffesymbol_global (s); + if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON)) + return; /* Let someone else catch this! */ + if (g->type == FFEGLOBAL_typeANY) + return; + + if (!g->u.common.have_save) + { + g->u.common.have_save = TRUE; + g->u.common.save = save; + g->u.common.save_where_line = ffewhere_line_use (wl); + g->u.common.save_where_col = ffewhere_column_use (wc); + } + else + { + if ((g->u.common.save != save) && ffe_is_pedantic ()) + { + ffebad_start (FFEBAD_COMMON_DIFF_SAVE); + ffebad_string (ffesymbol_text (s)); + ffebad_here (save ? 0 : 1, wl, wc); + ffebad_here (save ? 1 : 0, g->u.common.pad_where_line, g->u.common.pad_where_col); + ffebad_finish (); + } + } +#endif +} + +/* ffeglobal_size_common -- Establish size of COMMON area + + ffesymbol s; // the common area + long size; // size in units + if (ffeglobal_size_common(s,size)) // new size is largest seen + + In global-enabled mode, set the size if it current size isn't known or is + smaller than new size, and for non-blank common, complain if old size + is different from new. Return TRUE if the new size is the largest seen + for this COMMON area (or if no size was known for it previously). + In global-disabled mode, do nothing. */ + +#if FFEGLOBAL_ENABLED +bool +ffeglobal_size_common (ffesymbol s, long size) +{ + ffeglobal g; + + g = ffesymbol_global (s); + if ((g == NULL) || (g->type != FFEGLOBAL_typeCOMMON)) + return FALSE; + if (g->type == FFEGLOBAL_typeANY) + return FALSE; + + if (!g->u.common.have_size) + { + g->u.common.have_size = TRUE; + g->u.common.size = size; + return TRUE; + } + + if ((g->u.common.size < size) && (g->tick > 0) && (g->tick < ffe_count_2)) + { + char oldsize[40]; + char newsize[40]; + + sprintf (&oldsize[0], "%ld", g->u.common.size); + sprintf (&newsize[0], "%ld", size); + + ffebad_start (FFEBAD_COMMON_ENLARGED); + ffebad_string (ffesymbol_text (s)); + ffebad_string (oldsize); + ffebad_string (newsize); + ffebad_string ((g->u.common.size == 1) + ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS); + ffebad_string ((size == 1) + ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS); + ffebad_here (0, ffelex_token_where_line (g->u.common.initt), + ffelex_token_where_column (g->u.common.initt)); + ffebad_here (1, ffesymbol_where_line (s), + ffesymbol_where_column (s)); + ffebad_finish (); + } + else if ((g->u.common.size != size) && !g->u.common.blank) + { + char oldsize[40]; + char newsize[40]; + + /* Warn about this even if not -pedantic, because putting all + program units in a single source file is the only way to + detect this. Apparently UNIX-model linkers neither handle + nor report when they make a common unit smaller than + requested, such as when the smaller-declared version is + initialized and the larger-declared version is not. So + if people complain about strange overwriting, we can tell + them to put all their code in a single file and compile + that way. Warnings about differing sizes must therefore + always be issued. */ + + sprintf (&oldsize[0], "%ld", g->u.common.size); + sprintf (&newsize[0], "%ld", size); + + ffebad_start (FFEBAD_COMMON_DIFF_SIZE); + ffebad_string (ffesymbol_text (s)); + ffebad_string (oldsize); + ffebad_string (newsize); + ffebad_string ((g->u.common.size == 1) + ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS); + ffebad_string ((size == 1) + ? FFECOM_SIZE_UNIT : FFECOM_SIZE_UNITS); + ffebad_here (0, ffelex_token_where_line (g->t), + ffelex_token_where_column (g->t)); + ffebad_here (1, ffesymbol_where_line (s), + ffesymbol_where_column (s)); + ffebad_finish (); + } + + if (size > g->u.common.size) + { + g->u.common.size = size; + return TRUE; + } + return FALSE; +} + +#endif +void +ffeglobal_terminate_1 () +{ +} diff --git a/gcc/f/global.h b/gcc/f/global.h new file mode 100644 index 000000000000..fe0be038d21a --- /dev/null +++ b/gcc/f/global.h @@ -0,0 +1,201 @@ +/* global.h -- Public #include File (module.h template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + global.c + + Modifications: +*/ + +/* Allow multiple inclusion to work. */ + +#ifndef _H_f_global +#define _H_f_global + +/* Simple definitions and enumerations. */ + +typedef enum + { + FFEGLOBAL_typeNONE, + FFEGLOBAL_typeMAIN, + FFEGLOBAL_typeEXT, /* EXTERNAL is all we know. */ + FFEGLOBAL_typeSUBR, + FFEGLOBAL_typeFUNC, + FFEGLOBAL_typeBDATA, + FFEGLOBAL_typeCOMMON, + FFEGLOBAL_typeANY, /* Confusion reigns, so just ignore. */ + FFEGLOBAL_type + } ffeglobalType; + +typedef enum + { + FFEGLOBAL_argsummaryNONE, /* No arg present. */ + FFEGLOBAL_argsummaryVAL, /* Pass-by-value. */ + FFEGLOBAL_argsummaryREF, /* Pass-by-reference. */ + FFEGLOBAL_argsummaryDESCR, /* Pass-by-descriptor. */ + FFEGLOBAL_argsummaryPROC, /* Procedure (intrinsic, external). */ + FFEGLOBAL_argsummarySUBR, /* Subroutine (intrinsic, external). */ + FFEGLOBAL_argsummaryFUNC, /* Function (intrinsic, external). */ + FFEGLOBAL_argsummaryALTRTN, /* Alternate-return (label). */ + FFEGLOBAL_argsummaryPTR, /* Pointer (%LOC, LOC()). */ + FFEGLOBAL_argsummaryANY, + FFEGLOBAL_argsummary + } ffeglobalArgSummary; + +/* Typedefs. */ + +typedef struct _ffeglobal_arginfo_ *ffeglobalArgInfo_; +typedef struct _ffeglobal_ *ffeglobal; + +/* Include files needed by this one. */ + +#include "info.h" +#include "lex.h" +#include "name.h" +#include "symbol.h" +#include "target.h" +#include "top.h" + +/* Structure definitions. */ + +struct _ffeglobal_arginfo_ +{ + ffelexToken t; /* Different from master token when difference is important. */ + char *name; /* Name of dummy arg, or NULL if not yet known. */ + ffeglobalArgSummary as; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + bool array; +}; + +struct _ffeglobal_ +{ + ffelexToken t; + ffename n; +#ifdef FFECOM_globalHOOK + ffecomGlobal hook; +#endif + ffeCounter tick; /* Recent transition in this progunit. */ + ffeglobalType type; + bool intrinsic; /* Known as intrinsic? */ + bool explicit_intrinsic; /* Explicit intrinsic? */ + union { + struct { + ffelexToken initt; /* First initial value. */ + bool have_pad; /* Padding info avail for COMMON? */ + ffetargetAlign pad; /* Initial padding for COMMON. */ + ffewhereLine pad_where_line; + ffewhereColumn pad_where_col; + bool have_save; /* Save info avail for COMMON? */ + bool save; /* Save info for COMMON. */ + ffewhereLine save_where_line; + ffewhereColumn save_where_col; + bool have_size; /* Size info avail for COMMON? */ + long size; /* Size info for COMMON. */ + bool blank; /* TRUE if blank COMMON. */ + } common; + struct { + bool defined; /* Seen actual code yet? */ + ffeinfoBasictype bt; /* NONE for non-function. */ + ffeinfoKindtype kt; /* NONE for non-function. */ + ffetargetCharacterSize sz; + int n_args; /* 0 for main/blockdata. */ + ffelexToken other_t; /* Location of reference. */ + ffeglobalArgInfo_ arg_info; /* Info on each argument. */ + } proc; + } u; +}; + +/* Global objects accessed by users of this module. */ + + +/* Declare functions with prototypes. */ + +void ffeglobal_drive (ffeglobal (*fn) ()); +void ffeglobal_init_1 (void); +void ffeglobal_init_common (ffesymbol s, ffelexToken t); +void ffeglobal_new_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type); +void ffeglobal_new_common (ffesymbol s, ffelexToken t, bool blank); +void ffeglobal_pad_common (ffesymbol s, ffetargetAlign pad, ffewhereLine wl, + ffewhereColumn wc); +void ffeglobal_proc_def_arg (ffesymbol s, int argno, char *name, ffeglobalArgSummary as, + ffeinfoBasictype bt, ffeinfoKindtype kt, + bool array); +void ffeglobal_proc_def_nargs (ffesymbol s, int n_args); +bool ffeglobal_proc_ref_arg (ffesymbol s, int argno, ffeglobalArgSummary as, + ffeinfoBasictype bt, ffeinfoKindtype kt, + bool array, ffelexToken t); +bool ffeglobal_proc_ref_nargs (ffesymbol s, int n_args, ffelexToken t); +ffeglobal ffeglobal_promoted (ffesymbol s); +void ffeglobal_ref_intrinsic (ffesymbol s, ffelexToken t, bool explicit); +bool ffeglobal_ref_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type); +void ffeglobal_save_common (ffesymbol s, bool save, ffewhereLine wl, + ffewhereColumn wc); +bool ffeglobal_size_common (ffesymbol s, long size); +void ffeglobal_terminate_1 (void); + +/* 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) +#define ffeglobal_common_have_size(g) ((g)->u.common.have_size) +#define ffeglobal_common_size(g) ((g)->u.common.size) +#define ffeglobal_hook(g) ((g)->hook) +#define ffeglobal_init_0() +#define ffeglobal_init_2() +#define ffeglobal_init_3() +#define ffeglobal_init_4() +#define ffeglobal_new_blockdata(s,t) \ + ffeglobal_new_progunit_(s,t,FFEGLOBAL_typeBDATA) +#define ffeglobal_new_function(s,t) \ + ffeglobal_new_progunit_(s,t,FFEGLOBAL_typeFUNC) +#define ffeglobal_new_program(s,t) \ + ffeglobal_new_progunit_(s,t,FFEGLOBAL_typeMAIN) +#define ffeglobal_new_subroutine(s,t) \ + ffeglobal_new_progunit_(s,t,FFEGLOBAL_typeSUBR) +#define ffeglobal_pad(g) ((g)->pad) +#define ffeglobal_ref_blockdata(s,t) \ + ffeglobal_ref_progunit_(s,t,FFEGLOBAL_typeBDATA) +#define ffeglobal_ref_external(s,t) \ + ffeglobal_ref_progunit_(s,t,FFEGLOBAL_typeEXT) +#define ffeglobal_ref_function(s,t) \ + ffeglobal_ref_progunit_(s,t,FFEGLOBAL_typeFUNC) +#define ffeglobal_ref_subroutine(s,t) \ + ffeglobal_ref_progunit_(s,t,FFEGLOBAL_typeSUBR) +#define ffeglobal_set_hook(g,h) ((g)->hook = (h)) +#define ffeglobal_terminate_0() +#define ffeglobal_terminate_2() +#define ffeglobal_terminate_3() +#define ffeglobal_terminate_4() +#define ffeglobal_text(g) ffename_text((g)->n) +#define ffeglobal_type(g) ((g)->type) + +/* End of #include file. */ + +#endif diff --git a/gcc/f/hconfig.j b/gcc/f/hconfig.j new file mode 100644 index 000000000000..b777b68b92dc --- /dev/null +++ b/gcc/f/hconfig.j @@ -0,0 +1,27 @@ +/* hconfig.j -- Wrapper for GCC's hconfig.h + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. */ + +#ifndef MAKING_DEPENDENCIES +#ifndef _J_f_hconfig +#define _J_f_hconfig +#include "hconfig.h" +#endif +#endif diff --git a/gcc/f/implic.c b/gcc/f/implic.c new file mode 100644 index 000000000000..292f88f7410e --- /dev/null +++ b/gcc/f/implic.c @@ -0,0 +1,383 @@ +/* implic.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + None. + + Description: + The GNU Fortran Front End. + + Modifications: +*/ + +/* Include files. */ + +#include "proj.h" +#include +#include "implic.h" +#include "info.h" +#include "src.h" +#include "symbol.h" +#include "target.h" + +/* Externals defined here. */ + + +/* Simple definitions and enumerations. */ + +typedef enum + { + FFEIMPLIC_stateINITIAL_, + FFEIMPLIC_stateASSUMED_, + FFEIMPLIC_stateESTABLISHED_, + FFEIMPLIC_state + } ffeimplicState_; + +/* Internal typedefs. */ + +typedef struct _ffeimplic_ *ffeimplic_; + +/* Private include files. */ + + +/* Internal structure definitions. */ + +struct _ffeimplic_ + { + ffeimplicState_ state; + ffeinfo info; + }; + +/* Static objects accessed by functions in this module. */ + +/* NOTE: This is definitely ASCII-specific!! */ + +static struct _ffeimplic_ ffeimplic_table_['z' - 'A' + 1]; + +/* Static functions (internal). */ + +static ffeimplic_ ffeimplic_lookup_ (char c); + +/* Internal macros. */ + + +/* ffeimplic_lookup_ -- Look up implicit descriptor for initial character + + ffeimplic_ imp; + if ((imp = ffeimplic_lookup_('A')) == NULL) + // error + + Returns a pointer to an implicit descriptor block based on the character + passed, or NULL if it is not a valid initial character for an implicit + data type. */ + +static ffeimplic_ +ffeimplic_lookup_ (char c) +{ + /* NOTE: This is definitely ASCII-specific!! */ + if (isalpha (c) || (c == '_')) + return &ffeimplic_table_[c - 'A']; + return NULL; +} + +/* ffeimplic_establish_initial -- Establish type of implicit initial letter + + ffesymbol s; + if (!ffeimplic_establish_initial(s)) + // error + + Assigns implicit type information to the symbol based on the first + character of the symbol's name. */ + +bool +ffeimplic_establish_initial (char c, ffeinfoBasictype basic_type, + ffeinfoKindtype kind_type, ffetargetCharacterSize size) +{ + ffeimplic_ imp; + + imp = ffeimplic_lookup_ (c); + if (imp == NULL) + return FALSE; /* Character not A-Z or some such thing. */ + if (ffeinfo_basictype (imp->info) == FFEINFO_basictypeNONE) + return FALSE; /* IMPLICIT NONE in effect here. */ + + switch (imp->state) + { + case FFEIMPLIC_stateINITIAL_: + imp->info = ffeinfo_new (basic_type, + kind_type, + 0, + FFEINFO_kindNONE, + FFEINFO_whereNONE, + size); + imp->state = FFEIMPLIC_stateESTABLISHED_; + return TRUE; + + case FFEIMPLIC_stateASSUMED_: + if ((ffeinfo_basictype (imp->info) != basic_type) + || (ffeinfo_kindtype (imp->info) != kind_type) + || (ffeinfo_size (imp->info) != size)) + return FALSE; + imp->state = FFEIMPLIC_stateESTABLISHED_; + return TRUE; + + case FFEIMPLIC_stateESTABLISHED_: + return FALSE; + + default: + assert ("Weird state for implicit object" == NULL); + return FALSE; + } +} + +/* ffeimplic_establish_symbol -- Establish implicit type of a symbol + + ffesymbol s; + if (!ffeimplic_establish_symbol(s)) + // error + + Assigns implicit type information to the symbol based on the first + character of the symbol's name. + + If symbol already has a type, return TRUE. + Get first character of symbol's name. + Get ffeimplic_ object for it (return FALSE if NULL returned). + Return FALSE if object has no assigned type (IMPLICIT NONE). + Copy the type information from the object to the symbol. + If the object is state "INITIAL", set to state "ASSUMED" so no + subsequent IMPLICIT statement may change the state. + Return TRUE. */ + +bool +ffeimplic_establish_symbol (ffesymbol s) +{ + char c; + ffeimplic_ imp; + + if (ffesymbol_basictype (s) != FFEINFO_basictypeNONE) + return TRUE; + + c = *(ffesymbol_text (s)); + imp = ffeimplic_lookup_ (c); + if (imp == NULL) + return FALSE; /* First character not A-Z or some such + thing. */ + if (ffeinfo_basictype (imp->info) == FFEINFO_basictypeNONE) + return FALSE; /* IMPLICIT NONE in effect here. */ + + ffesymbol_signal_change (s); /* Gonna change, save existing? */ + + /* Establish basictype, kindtype, size; preserve rank, kind, where. */ + + ffesymbol_set_info (s, + ffeinfo_new (ffeinfo_basictype (imp->info), + ffeinfo_kindtype (imp->info), + ffesymbol_rank (s), + ffesymbol_kind (s), + ffesymbol_where (s), + ffeinfo_size (imp->info))); + + if (imp->state == FFEIMPLIC_stateINITIAL_) + imp->state = FFEIMPLIC_stateASSUMED_; + + if (ffe_is_warn_implicit ()) + { + ffebad_start_msg ("Implicit declaration of `%A' at %0", + FFEBAD_severityWARNING); + ffebad_here (0, ffesymbol_where_line (s), + ffesymbol_where_column (s)); + ffebad_string (ffesymbol_text (s)); + ffebad_finish (); + } + + return TRUE; +} + +/* ffeimplic_init_2 -- Initialize table + + ffeimplic_init_2(); + + Assigns initial type information to all initial letters. + + Allows for holes in the sequence of letters (i.e. EBCDIC). */ + +void +ffeimplic_init_2 () +{ + ffeimplic_ imp; + char c; + + for (c = 'A'; c <= 'z'; ++c) + { + imp = &ffeimplic_table_[c - 'A']; + imp->state = FFEIMPLIC_stateINITIAL_; + switch (c) + { + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + case 'G': + case 'H': + case 'O': + case 'P': + case 'Q': + case 'R': + case 'S': + case 'T': + case 'U': + case 'V': + case 'W': + case 'X': + case 'Y': + case 'Z': + case '_': + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'g': + case 'h': + case 'o': + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + case 'z': + imp->info = ffeinfo_new (FFEINFO_basictypeREAL, + FFEINFO_kindtypeREALDEFAULT, + 0, + FFEINFO_kindNONE, + FFEINFO_whereNONE, + FFETARGET_charactersizeNONE); + break; + + case 'I': + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'i': + case 'j': + case 'k': + case 'l': + case 'm': + case 'n': + imp->info = ffeinfo_new (FFEINFO_basictypeINTEGER, + FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindNONE, FFEINFO_whereNONE, + FFETARGET_charactersizeNONE); + break; + + default: + imp->info = ffeinfo_new (FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0, + FFEINFO_kindNONE, FFEINFO_whereNONE, FFETARGET_charactersizeNONE); + break; + } + } +} + +/* ffeimplic_none -- Implement IMPLICIT NONE statement + + ffeimplic_none(); + + Assigns null type information to all initial letters. */ + +void +ffeimplic_none () +{ + ffeimplic_ imp; + + for (imp = &ffeimplic_table_[0]; + imp != &ffeimplic_table_[ARRAY_SIZE (ffeimplic_table_)]; + imp++) + { + imp->info = ffeinfo_new (FFEINFO_basictypeNONE, + FFEINFO_kindtypeNONE, + 0, + FFEINFO_kindNONE, + FFEINFO_whereNONE, + FFETARGET_charactersizeNONE); + } +} + +/* ffeimplic_peek_symbol_type -- Determine implicit type of a symbol + + ffesymbol s; + char *name; // name for s in case it is NULL, or NULL if s never NULL + if (ffeimplic_peek_symbol_type(s,name) == FFEINFO_basictypeCHARACTER) + // is or will be a CHARACTER-typed name + + Like establish_symbol, but doesn't change anything. + + If symbol is non-NULL and already has a type, return it. + Get first character of symbol's name or from name arg if symbol is NULL. + Get ffeimplic_ object for it (return FALSE if NULL returned). + Return NONE if object has no assigned type (IMPLICIT NONE). + Return the data type indicated in the object. + + 24-Oct-91 JCB 2.0 + Take a char * instead of ffelexToken, since the latter isn't always + needed anyway (as when ffecom calls it). */ + +ffeinfoBasictype +ffeimplic_peek_symbol_type (ffesymbol s, char *name) +{ + char c; + ffeimplic_ imp; + + if (s == NULL) + c = *name; + else + { + if (ffesymbol_basictype (s) != FFEINFO_basictypeNONE) + return ffesymbol_basictype (s); + + c = *(ffesymbol_text (s)); + } + + imp = ffeimplic_lookup_ (c); + if (imp == NULL) + return FFEINFO_basictypeNONE; /* First character not A-Z or + something. */ + return ffeinfo_basictype (imp->info); +} + +/* ffeimplic_terminate_2 -- Terminate table + + ffeimplic_terminate_2(); + + Kills info object for each entry in table. */ + +void +ffeimplic_terminate_2 () +{ +} diff --git a/gcc/f/implic.h b/gcc/f/implic.h new file mode 100644 index 000000000000..2c03ab2cde1d --- /dev/null +++ b/gcc/f/implic.h @@ -0,0 +1,74 @@ +/* implic.h -- Public #include File (module.h template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + implic.c + + Modifications: +*/ + +/* Allow multiple inclusion to work. */ + +#ifndef _H_f_implic +#define _H_f_implic + +/* Simple definitions and enumerations. */ + + +/* Typedefs. */ + + +/* Include files needed by this one. */ + +#include "info.h" +#include "symbol.h" +#include "target.h" + +/* Structure definitions. */ + + +/* Global objects accessed by users of this module. */ + + +/* Declare functions with prototypes. */ + +bool ffeimplic_establish_initial (char c, ffeinfoBasictype basic_type, + ffeinfoKindtype kind_type, ffetargetCharacterSize size); +bool ffeimplic_establish_symbol (ffesymbol s); +void ffeimplic_init_2 (void); +void ffeimplic_none (void); +ffeinfoBasictype ffeimplic_peek_symbol_type (ffesymbol s, char *name); +void ffeimplic_terminate_2 (void); + +/* Define macros. */ + +#define ffeimplic_init_0() +#define ffeimplic_init_1() +#define ffeimplic_init_3() +#define ffeimplic_init_4() +#define ffeimplic_terminate_0() +#define ffeimplic_terminate_1() +#define ffeimplic_terminate_3() +#define ffeimplic_terminate_4() + +/* End of #include file. */ + +#endif diff --git a/gcc/f/info-b.def b/gcc/f/info-b.def new file mode 100644 index 000000000000..0084f7afc99f --- /dev/null +++ b/gcc/f/info-b.def @@ -0,0 +1,36 @@ +/* info-b.def -- Public #include File (module.h template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + info.c + + Modifications: +*/ + +FFEINFO_BASICTYPE (FFEINFO_basictypeNONE, "None", "") +FFEINFO_BASICTYPE (FFEINFO_basictypeINTEGER, "INTEGER", "i") +FFEINFO_BASICTYPE (FFEINFO_basictypeLOGICAL, "LOGICAL", "l") +FFEINFO_BASICTYPE (FFEINFO_basictypeREAL, "REAL", "r") +FFEINFO_BASICTYPE (FFEINFO_basictypeCOMPLEX, "COMPLEX", "c") +FFEINFO_BASICTYPE (FFEINFO_basictypeCHARACTER, "CHARACTER", "a") +FFEINFO_BASICTYPE (FFEINFO_basictypeHOLLERITH, "Hollerith", "h") +FFEINFO_BASICTYPE (FFEINFO_basictypeTYPELESS, "Typeless", "t") +FFEINFO_BASICTYPE (FFEINFO_basictypeANY, "Any", "~") diff --git a/gcc/f/info-k.def b/gcc/f/info-k.def new file mode 100644 index 000000000000..46e32b27e50d --- /dev/null +++ b/gcc/f/info-k.def @@ -0,0 +1,37 @@ +/* info-k.def -- Public #include File (module.h template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + info.c + + Modifications: +*/ + +FFEINFO_KIND (FFEINFO_kindNONE, "an unknown kind", "") +FFEINFO_KIND (FFEINFO_kindENTITY, "an entity", "e") +FFEINFO_KIND (FFEINFO_kindFUNCTION, "a function", "f") +FFEINFO_KIND (FFEINFO_kindSUBROUTINE, "a subroutine", "u") +FFEINFO_KIND (FFEINFO_kindPROGRAM, "a program", "p") +FFEINFO_KIND (FFEINFO_kindBLOCKDATA, "a block-data unit", "b") +FFEINFO_KIND (FFEINFO_kindCOMMON, "a common block", "c") +FFEINFO_KIND (FFEINFO_kindCONSTRUCT, "a construct", ":") +FFEINFO_KIND (FFEINFO_kindNAMELIST, "a namelist", "n") +FFEINFO_KIND (FFEINFO_kindANY, "anything", "~") diff --git a/gcc/f/info-w.def b/gcc/f/info-w.def new file mode 100644 index 000000000000..14e8a583a682 --- /dev/null +++ b/gcc/f/info-w.def @@ -0,0 +1,41 @@ +/* info-w.def -- Public #include File (module.h template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + info.c + + Modifications: +*/ + +FFEINFO_WHERE (FFEINFO_whereNONE, "None", "") +FFEINFO_WHERE (FFEINFO_whereLOCAL, "Local", "l") /* Defined locally. */ +FFEINFO_WHERE (FFEINFO_whereCOMMON, "Common", "c") /* In a common area. */ +FFEINFO_WHERE (FFEINFO_whereDUMMY, "Dummy", "d") /* A dummy argument. */ +FFEINFO_WHERE (FFEINFO_whereGLOBAL, "Global", "g") /* Reference to external global like FUNCTION, SUBR. */ +FFEINFO_WHERE (FFEINFO_whereRESULT, "Result", "r") /* Result of this function. */ +FFEINFO_WHERE (FFEINFO_whereFLEETING, "Fleeting", "f") /* Result of "X*Y", "FUNCREF(5,1.3)", "ARRAY(X)", etc. */ +FFEINFO_WHERE (FFEINFO_whereFLEETING_CADDR, "Fleet-Const", "fp") /* "A(3)", "CHARS(4:5)". */ +FFEINFO_WHERE (FFEINFO_whereFLEETING_IADDR, "Fleet-Immed", "fi") /* A(IX) in "DATA (A(IX),IX=1,100)/.../". */ +FFEINFO_WHERE (FFEINFO_whereIMMEDIATE, "Immediate", "i") /* IX in "DATA (A(IX),IX=1,100)/.../". */ +FFEINFO_WHERE (FFEINFO_whereINTRINSIC, "Intrinsic", "b") +FFEINFO_WHERE (FFEINFO_whereCONSTANT, "Constant", "p") /* For kindFUNCTION, means statement function! */ +FFEINFO_WHERE (FFEINFO_whereCONSTANT_SUBOBJECT, "Const-subobj", "q") /* As in "'FOO'(I:J)". */ +FFEINFO_WHERE (FFEINFO_whereANY, "Any", "~") diff --git a/gcc/f/info.c b/gcc/f/info.c new file mode 100644 index 000000000000..7c1ca9b0155f --- /dev/null +++ b/gcc/f/info.c @@ -0,0 +1,305 @@ +/* info.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + None + + Description: + An abstraction for information maintained on a per-operator and per- + operand basis in expression trees. + + Modifications: + 30-Aug-90 JCB 2.0 + Extensive rewrite for new cleaner approach. +*/ + +/* Include files. */ + +#include "proj.h" +#include "info.h" +#include "target.h" +#include "type.h" + +/* Externals defined here. */ + + +/* Simple definitions and enumerations. */ + + +/* Internal typedefs. */ + + +/* Private include files. */ + + +/* Internal structure definitions. */ + + +/* Static objects accessed by functions in this module. */ + +static char *ffeinfo_basictype_string_[] += +{ +#define FFEINFO_BASICTYPE(KWD,LNAM,SNAM) SNAM, +#include "info-b.def" +#undef FFEINFO_BASICTYPE +}; +static char *ffeinfo_kind_message_[] += +{ +#define FFEINFO_KIND(KWD,LNAM,SNAM) LNAM, +#include "info-k.def" +#undef FFEINFO_KIND +}; +static char *ffeinfo_kind_string_[] += +{ +#define FFEINFO_KIND(KWD,LNAM,SNAM) SNAM, +#include "info-k.def" +#undef FFEINFO_KIND +}; +static ffeinfoBasictype ffeinfo_combine_[FFEINFO_basictype][FFEINFO_basictype]; +static char *ffeinfo_kindtype_string_[] += +{ + "", + "1", + "2", + "3", + "4", + "5", + "6", + "7", + "8", + "*", +}; +static char *ffeinfo_where_string_[] += +{ +#define FFEINFO_WHERE(KWD,LNAM,SNAM) SNAM, +#include "info-w.def" +#undef FFEINFO_WHERE +}; +static ffetype ffeinfo_types_[FFEINFO_basictype][FFEINFO_kindtype] + = { { NULL } }; + +/* Static functions (internal). */ + + +/* Internal macros. */ + + +/* ffeinfo_basictype_combine -- Combine two basictypes into highest rank type + + ffeinfoBasictype i, j, k; + k = ffeinfo_basictype_combine(i,j); + + Returns a type based on "standard" operation between two given types. */ + +ffeinfoBasictype +ffeinfo_basictype_combine (ffeinfoBasictype l, ffeinfoBasictype r) +{ + assert (l < FFEINFO_basictype); + assert (r < FFEINFO_basictype); + return ffeinfo_combine_[l][r]; +} + +/* ffeinfo_basictype_string -- Return tiny string showing the basictype + + ffeinfoBasictype i; + printf("%s",ffeinfo_basictype_string(dt)); + + Returns the string based on the basic type. */ + +char * +ffeinfo_basictype_string (ffeinfoBasictype basictype) +{ + if (basictype >= ARRAY_SIZE (ffeinfo_basictype_string_)) + return "?\?\?"; + return ffeinfo_basictype_string_[basictype]; +} + +/* ffeinfo_init_0 -- Initialize + + ffeinfo_init_0(); */ + +void +ffeinfo_init_0 () +{ + ffeinfoBasictype i; + ffeinfoBasictype j; + + assert (FFEINFO_basictype == ARRAY_SIZE (ffeinfo_basictype_string_)); + assert (FFEINFO_kind == ARRAY_SIZE (ffeinfo_kind_message_)); + assert (FFEINFO_kind == ARRAY_SIZE (ffeinfo_kind_string_)); + assert (FFEINFO_kindtype == ARRAY_SIZE (ffeinfo_kindtype_string_)); + assert (FFEINFO_where == ARRAY_SIZE (ffeinfo_where_string_)); + + /* Make array that, given two basic types, produces resulting basic type. */ + + for (i = 0; i < FFEINFO_basictype; ++i) + for (j = 0; j < FFEINFO_basictype; ++j) + if ((i == FFEINFO_basictypeANY) || (j == FFEINFO_basictypeANY)) + ffeinfo_combine_[i][j] = FFEINFO_basictypeANY; + else + ffeinfo_combine_[i][j] = FFEINFO_basictypeNONE; + +#define same(bt) ffeinfo_combine_[bt][bt] = bt +#define use2(bt1,bt2) ffeinfo_combine_[bt1][bt2] \ + = ffeinfo_combine_[bt2][bt1] = bt2 + + same (FFEINFO_basictypeINTEGER); + same (FFEINFO_basictypeLOGICAL); + same (FFEINFO_basictypeREAL); + same (FFEINFO_basictypeCOMPLEX); + same (FFEINFO_basictypeCHARACTER); + use2 (FFEINFO_basictypeINTEGER, FFEINFO_basictypeREAL); + use2 (FFEINFO_basictypeINTEGER, FFEINFO_basictypeCOMPLEX); + use2 (FFEINFO_basictypeREAL, FFEINFO_basictypeCOMPLEX); + +#undef same +#undef use2 +} + +/* ffeinfo_kind_message -- Return helpful string showing the kind + + ffeinfoKind kind; + printf("%s",ffeinfo_kind_message(kind)); + + Returns the string based on the kind. */ + +char * +ffeinfo_kind_message (ffeinfoKind kind) +{ + if (kind >= ARRAY_SIZE (ffeinfo_kind_message_)) + return "?\?\?"; + return ffeinfo_kind_message_[kind]; +} + +/* ffeinfo_kind_string -- Return tiny string showing the kind + + ffeinfoKind kind; + printf("%s",ffeinfo_kind_string(kind)); + + Returns the string based on the kind. */ + +char * +ffeinfo_kind_string (ffeinfoKind kind) +{ + if (kind >= ARRAY_SIZE (ffeinfo_kind_string_)) + return "?\?\?"; + return ffeinfo_kind_string_[kind]; +} + +ffeinfoKindtype +ffeinfo_kindtype_max(ffeinfoBasictype bt, + ffeinfoKindtype k1, + ffeinfoKindtype k2) +{ + if ((bt == FFEINFO_basictypeANY) + || (k1 == FFEINFO_kindtypeANY) + || (k2 == FFEINFO_kindtypeANY)) + return FFEINFO_kindtypeANY; + + if (ffetype_size (ffeinfo_types_[bt][k1]) + > ffetype_size (ffeinfo_types_[bt][k2])) + return k1; + return k2; +} + +/* ffeinfo_kindtype_string -- Return tiny string showing the kind type + + ffeinfoKindtype kind_type; + printf("%s",ffeinfo_kindtype_string(kind)); + + Returns the string based on the kind type. */ + +char * +ffeinfo_kindtype_string (ffeinfoKindtype kind_type) +{ + if (kind_type >= ARRAY_SIZE (ffeinfo_kindtype_string_)) + return "?\?\?"; + return ffeinfo_kindtype_string_[kind_type]; +} + +void +ffeinfo_set_type (ffeinfoBasictype basictype, ffeinfoKindtype kindtype, + ffetype type) +{ + assert (basictype < FFEINFO_basictype); + assert (kindtype < FFEINFO_kindtype); + assert (ffeinfo_types_[basictype][kindtype] == NULL); + + ffeinfo_types_[basictype][kindtype] = type; +} + +ffetype +ffeinfo_type (ffeinfoBasictype basictype, ffeinfoKindtype kindtype) +{ + assert (basictype < FFEINFO_basictype); + assert (kindtype < FFEINFO_kindtype); + assert (ffeinfo_types_[basictype][kindtype] != NULL); + + return ffeinfo_types_[basictype][kindtype]; +} + +/* ffeinfo_where_string -- Return tiny string showing the where + + ffeinfoWhere where; + printf("%s",ffeinfo_where_string(where)); + + Returns the string based on the where. */ + +char * +ffeinfo_where_string (ffeinfoWhere where) +{ + if (where >= ARRAY_SIZE (ffeinfo_where_string_)) + return "?\?\?"; + return ffeinfo_where_string_[where]; +} + +/* ffeinfo_new -- Return object representing datatype, kind, and where info + + ffeinfo i; + i = ffeinfo_new(FFEINFO_datatypeINTEGER,FFEINFO_kindSCALAR, + FFEINFO_whereLOCAL); + + Returns the string based on the data type. */ + +#ifndef __GNUC__ +ffeinfo +ffeinfo_new (ffeinfoBasictype basictype, ffeinfoKindtype kindtype, + ffeinfoRank rank, ffeinfoKind kind, ffeinfoWhere where, + ffetargetCharacterSize size) +{ + ffeinfo i; + + i.basictype = basictype; + i.kindtype = kindtype; + i.rank = rank; + i.size = size; + i.kind = kind; + i.where = where; + i.size = size; + + return i; +} +#endif diff --git a/gcc/f/info.h b/gcc/f/info.h new file mode 100644 index 000000000000..33f1aa9e61ed --- /dev/null +++ b/gcc/f/info.h @@ -0,0 +1,186 @@ +/* info.h -- Public #include File (module.h template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + info.c + + Modifications: + 30-Aug-90 JCB 2.0 + Extensive rewrite for new cleaner approach. +*/ + +/* Allow multiple inclusion to work. */ + +#ifndef _H_f_info +#define _H_f_info + +/* Simple definitions and enumerations. */ + +typedef enum + { +#define FFEINFO_BASICTYPE(KWD,LNAM,SNAM) KWD, +#include "info-b.def" +#undef FFEINFO_BASICTYPE + FFEINFO_basictype + } ffeinfoBasictype; + +typedef enum + { /* If these kindtypes aren't in size order, + change _kindtype_max. */ + FFEINFO_kindtypeNONE, + FFEINFO_kindtypeINTEGER1, + FFEINFO_kindtypeINTEGER2, + FFEINFO_kindtypeINTEGER3, + FFEINFO_kindtypeINTEGER4, + FFEINFO_kindtypeINTEGER5, + FFEINFO_kindtypeINTEGER6, + FFEINFO_kindtypeINTEGER7, + FFEINFO_kindtypeINTEGER8, + FFEINFO_kindtypeLOGICAL1 = 1, /* Ok to omit, but ok to overlap. */ + FFEINFO_kindtypeLOGICAL2, + FFEINFO_kindtypeLOGICAL3, + FFEINFO_kindtypeLOGICAL4, + FFEINFO_kindtypeLOGICAL5, + FFEINFO_kindtypeLOGICAL6, + FFEINFO_kindtypeLOGICAL7, + FFEINFO_kindtypeLOGICAL8, + FFEINFO_kindtypeREAL1 = 1, /* Ok to omit, but ok to overlap. */ + FFEINFO_kindtypeREAL2, + FFEINFO_kindtypeREAL3, + FFEINFO_kindtypeREAL4, + FFEINFO_kindtypeREAL5, + FFEINFO_kindtypeREAL6, + FFEINFO_kindtypeREAL7, + FFEINFO_kindtypeREAL8, + FFEINFO_kindtypeCHARACTER1 = 1, /* Ok to omit, but ok to overlap. */ + FFEINFO_kindtypeCHARACTER2, + FFEINFO_kindtypeCHARACTER3, + FFEINFO_kindtypeCHARACTER4, + FFEINFO_kindtypeCHARACTER5, + FFEINFO_kindtypeCHARACTER6, + FFEINFO_kindtypeCHARACTER7, + FFEINFO_kindtypeCHARACTER8, + FFEINFO_kindtypeANY, + FFEINFO_kindtype + } ffeinfoKindtype; + +typedef enum + { +#define FFEINFO_KIND(KWD,LNAM,SNAM) KWD, +#include "info-k.def" +#undef FFEINFO_KIND + FFEINFO_kind + } ffeinfoKind; + +typedef enum + { +#define FFEINFO_WHERE(KWD,LNAM,SNAM) KWD, +#include "info-w.def" +#undef FFEINFO_WHERE + FFEINFO_where + } ffeinfoWhere; + +/* Typedefs. */ + +typedef struct _ffeinfo_ ffeinfo; +typedef char ffeinfoRank; + +/* Include files needed by this one. */ + +#include "target.h" +#include "type.h" + +/* Structure definitions. */ + +struct _ffeinfo_ + { + ffeinfoBasictype basictype; + ffeinfoKindtype kindtype; + ffeinfoRank rank; + ffeinfoKind kind; + ffeinfoWhere where; + ffetargetCharacterSize size; + }; + +/* Global objects accessed by users of this module. */ + + +/* Declare functions with prototypes. */ + +ffeinfoBasictype ffeinfo_basictype_combine (ffeinfoBasictype l, + ffeinfoBasictype r); +char *ffeinfo_basictype_string (ffeinfoBasictype basictype); +void ffeinfo_init_0 (void); +char *ffeinfo_kind_message (ffeinfoKind kind); +char *ffeinfo_kind_string (ffeinfoKind kind); +ffeinfoKindtype ffeinfo_kindtype_max(ffeinfoBasictype bt, + ffeinfoKindtype k1, + ffeinfoKindtype k2); +char *ffeinfo_kindtype_string (ffeinfoKindtype kind_type); +char *ffeinfo_where_string (ffeinfoWhere where); +ffeinfo ffeinfo_new (ffeinfoBasictype basictype, ffeinfoKindtype kindtype, + ffeinfoRank rank, ffeinfoKind kind, ffeinfoWhere where, + ffetargetCharacterSize size); +void ffeinfo_set_type (ffeinfoBasictype basictype, ffeinfoKindtype kindtype, + ffetype type); +ffetype ffeinfo_type (ffeinfoBasictype basictype, ffeinfoKindtype kindtype); + +/* Define macros. */ + +#define ffeinfo_basictype(i) (i.basictype) +#define ffeinfo_init_1() +#define ffeinfo_init_2() +#define ffeinfo_init_3() +#define ffeinfo_init_4() +#define ffeinfo_kind(i) (i.kind) +#define ffeinfo_kindtype(i) (i.kindtype) +#ifdef __GNUC__ +#define ffeinfo_new(bt,kt,r,k,w,sz) \ + ((ffeinfo) {(bt), (kt), (r), (k), (w), (sz)}) +#endif +#define ffeinfo_new_any() \ + ffeinfo_new (FFEINFO_basictypeANY, FFEINFO_kindtypeANY, 0, \ + FFEINFO_kindANY, FFEINFO_whereANY, \ + FFETARGET_charactersizeNONE) +#define ffeinfo_new_null() \ + ffeinfo_new (FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0, \ + FFEINFO_kindNONE, FFEINFO_whereNONE, \ + FFETARGET_charactersizeNONE) +#define ffeinfo_rank(i) (i.rank) +#define ffeinfo_size(i) (i.size) +#define ffeinfo_terminate_0() +#define ffeinfo_terminate_1() +#define ffeinfo_terminate_2() +#define ffeinfo_terminate_3() +#define ffeinfo_terminate_4() +#define ffeinfo_use(i) i +#define ffeinfo_where(i) (i.where) + +#define FFEINFO_kindtypeINTEGERDEFAULT FFEINFO_kindtypeINTEGER1 +#define FFEINFO_kindtypeLOGICALDEFAULT FFEINFO_kindtypeLOGICAL1 +#define FFEINFO_kindtypeREALDEFAULT FFEINFO_kindtypeREAL1 +#define FFEINFO_kindtypeREALDOUBLE FFEINFO_kindtypeREAL2 +#define FFEINFO_kindtypeREALQUAD FFEINFO_kindtypeREAL3 +#define FFEINFO_kindtypeCHARACTERDEFAULT FFEINFO_kindtypeCHARACTER1 + +/* End of #include file. */ + +#endif diff --git a/gcc/f/input.j b/gcc/f/input.j new file mode 100644 index 000000000000..c7ec5b690ffa --- /dev/null +++ b/gcc/f/input.j @@ -0,0 +1,27 @@ +/* input.j -- Wrapper for GCC's input.h + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. */ + +#ifndef MAKING_DEPENDENCIES +#ifndef _J_f_input +#define _J_f_input +#include "input.h" +#endif +#endif diff --git a/gcc/f/install.texi b/gcc/f/install.texi new file mode 100644 index 000000000000..f6f403ddfdda --- /dev/null +++ b/gcc/f/install.texi @@ -0,0 +1,2036 @@ +@c Copyright (C) 1995-1997 Free Software Foundation, Inc. +@c This is part of the G77 manual. +@c For copying conditions, see the file g77.texi. + +@c The text of this file appears in the file INSTALL +@c in the G77 distribution, as well as in the G77 manual. + +@c 1997-08-11 + +@ifclear INSTALLONLY +@node Installation +@chapter Installing GNU Fortran +@end ifclear +@cindex installing GNU Fortran + +The following information describes how to install @code{g77}. + +The information in this file generally pertains to dealing +with @emph{source} distributions of @code{g77} and @code{gcc}. +It is possible that some of this information will be applicable +to some @emph{binary} distributions of these products---however, +since these distributions are not made by the maintainers of +@code{g77}, responsibility for binary distributions rests with +whoever built and first distributed them. + +Nevertheless, efforts to make @code{g77} easier to both build +and install from source and package up as a binary distribution +are ongoing. + +@menu +* Prerequisites:: Make sure your system is ready for @code{g77}. +* Problems Installing:: Known trouble areas. +* Settings:: Changing @code{g77} internals before building. +* Quick Start:: The easier procedure for non-experts. +* Complete Installation:: For experts, or those who want to be: the details. +* Distributing Binaries:: If you plan on distributing your @code{g77}. +@end menu + +@node Prerequisites +@section Prerequisites +@cindex prerequisites + +The procedures described to unpack, configure, build, and +install @code{g77} assume your system has certain programs +already installed. + +The following prerequisites should be met by your +system before you follow the @code{g77} installation instructions: + +@table @asis +@item @code{gzip} +To unpack the @code{gcc} and @code{g77} distributions, +you'll need the @code{gunzip} utility in the @code{gzip} +distribution. +Most UNIX systems already have @code{gzip} installed. +If yours doesn't, you can get it from the FSF. + +Note that you'll need @code{tar} and other utilities +as well, but all UNIX systems have these. +There are GNU versions of all these available---in fact, +a complete GNU UNIX system can be put together on +most systems, if desired. + +@item @file{gcc-2.7.2.2.tar.gz} +You need to have this, or some other applicable, version +of @code{gcc} on your system. +The version should be an exact copy of a distribution +from the FSF. +It is approximately 7MB large. + +If you've already unpacked @file{gcc-2.7.2.2.tar.gz} into a +directory (named @file{gcc-2.7.2.2}) called the @dfn{source tree} +for @code{gcc}, you can delete the distribution +itself, but you'll need to remember to skip any instructions to unpack +this distribution. + +Without an applicable @code{gcc} source tree, you cannot +build @code{g77}. +You can obtain an FSF distribution of @code{gcc} from the FSF. + +@item @file{g77-0.5.21.tar.gz} +You probably have already unpacked this distribution, +or you are reading an advanced copy of this manual, +which is contained in this distribution. +This distribution approximately 1MB large. + +You can obtain an FSF distribution of @code{g77} from the FSF, +the same way you obtained @code{gcc}. + +@item 100MB disk space +For a complete @dfn{bootstrap} build, about 100MB +of disk space is required for @code{g77} by the author's +current GNU/Linux system. + +Some juggling can reduce the amount of space needed; +during the bootstrap process, once Stage 3 starts, +during which the version of @code{gcc} that has been copied +into the @file{stage2/} directory is used to rebuild the +system, you can delete the @file{stage1/} directory +to free up some space. + +It is likely that many systems don't require the complete +bootstrap build, as they already have a recent version of +@code{gcc} installed. +Such systems might be able to build @code{g77} with only +about 75MB of free space. + +@item @code{patch} +Although you can do everything @code{patch} does yourself, +by hand, without much trouble, having @code{patch} installed +makes installation of new versions of GNU utilities such as +@code{g77} so much easier that it is worth getting. +You can obtain @code{patch} the same way you obtained +@code{gcc} and @code{g77}. + +In any case, you can apply patches by hand---patch files +are designed for humans to read them. + +@item @code{make} +Your system must have @code{make}, and you will probably save +yourself a lot of trouble if it is GNU @code{make} (sometimes +referred to as @code{gmake}). + +@item @code{cc} +Your system must have a working C compiler. + +@xref{Installation,,Installing GNU CC,gcc,Using and Porting GNU CC}, +for more information on prerequisites for installing @code{gcc}. + +@item @code{bison} +If you do not have @code{bison} installed, you can usually +work around any need for it, since @code{g77} itself does +not use it, and @code{gcc} normally includes all files +generated by running it in its distribution. +You can obtain @code{bison} the same way you obtained +@code{gcc} and @code{g77}. + +@xref{Missing bison?}, +for information on how to work around not having @code{bison}. + +@item @code{makeinfo} +If you are missing @code{makeinfo}, you can usually work +around any need for it. +You can obtain @code{makeinfo} the same way you obtained +@code{gcc} and @code{g77}. + +@xref{Missing makeinfo?}, +for information on getting around the lack of @code{makeinfo}. + +@item @code{root} access +To perform the complete installation procedures on a system, +you need to have @code{root} access to that system, or +equivalent access. + +Portions of the procedure (such as configuring and building +@code{g77}) can be performed by any user with enough disk +space and virtual memory. + +However, these instructions are oriented towards less-experienced +users who want to install @code{g77} on their own personal +systems. + +System administrators with more experience will want to +determine for themselves how they want to modify the +procedures described below to suit the needs of their +installation. +@end table + +@node Problems Installing +@section Problems Installing +@cindex problems installing +@cindex installation problems + +This is a list of problems (and some apparent problems which don't +really mean anything is wrong) that show up when configuring, +building, installing, or porting GNU Fortran. + +@xref{Installation Problems,,,gcc,Using and Porting GNU CC}, +for more information on installation problems that can afflict +either @code{gcc} or @code{g77}. + +@menu +* General Problems:: Problems afflicting most or all systems. +* Cross-compiler Problems:: Problems afflicting cross-compilation setups. +@end menu + +@node General Problems +@subsection General Problems + +These problems can occur on most or all systems. + +@menu +* GNU C Required:: Why even ANSI C is not enough. +* Patching GNU CC Necessary:: Why @code{gcc} must be patched first. +* Building GNU CC Necessary:: Why you can't build @emph{just} Fortran. +* Missing strtoul:: If linking @code{f771} fails due to an + unresolved reference to @code{strtoul}. +* Object File Differences:: It's okay that @samp{make compare} will + flag @file{f/zzz.o}. +* Cleanup Kills Stage Directories:: A minor nit for @code{g77} developers. +* Missing gperf?:: When building requires @code{gperf}. +@end menu + +@node GNU C Required +@subsubsection GNU C Required +@cindex GNU C required +@cindex requirements, GNU C + +Compiling @code{g77} requires GNU C, not just ANSI C. +Fixing this wouldn't +be very hard (just tedious), but the code using GNU extensions to +the C language is expected to be rewritten for 0.6 anyway, +so there are no plans for an interim fix. + +This requirement does not mean you must already have @code{gcc} +installed to build @code{g77}. +As long as you have a working C compiler, you can use a +bootstrap build to automate the process of first building +@code{gcc} using the working C compiler you have, then building +@code{g77} and rebuilding @code{gcc} using that just-built @code{gcc}, +and so on. + +@node Patching GNU CC Necessary +@subsubsection Patching GNU CC Necessary +@cindex patch files +@cindex GBE + +@code{g77} currently requires application of a patch file to the gcc compiler +tree. +The necessary patches should be folded in to the mainline gcc distribution. + +Some combinations +of versions of @code{g77} and @code{gcc} might actually @emph{require} no +patches, but the patch files will be provided anyway as long as +there are more changes expected in subsequent releases. +These patch files might contain +unnecessary, but possibly helpful, patches. +As a result, it is possible this issue might never be +resolved, except by eliminating the need for the person +configuring @code{g77} to apply a patch by hand, by going +to a more automated approach (such as configure-time patching). + +@node Building GNU CC Necessary +@subsubsection Building GNU CC Necessary +@cindex gcc, building +@cindex building gcc + +It should be possible to build the runtime without building @code{cc1} +and other non-Fortran items, but, for now, an easy way to do that +is not yet established. + +@node Missing strtoul +@subsubsection Missing strtoul +@cindex strtoul +@cindex _strtoul +@cindex undefined reference (_strtoul) +@cindex f771, linking error for +@cindex linking error for f771 +@cindex ld error for f771 +@cindex ld can't find _strtoul +@cindex SunOS4 + +On SunOS4 systems, linking the @code{f771} program produces +an error message concerning an undefined symbol named +@samp{_strtoul}. + +This is not a @code{g77} bug. +@xref{Patching GNU Fortran}, for information on +a workaround provided by @code{g77}. + +The proper fix is either to upgrade your system to one that +provides a complete ANSI C environment, or improve @code{gcc} so +that it provides one for all the languages and configurations it supports. + +@emph{Note:} In earlier versions of @code{g77}, an automated +workaround for this problem was attempted. +It worked for systems without @samp{_strtoul}, substituting +the incomplete-yet-sufficient version supplied with @code{g77} +for those systems. +However, the automated workaround failed mysteriously for systems +that appeared to have conforming ANSI C environments, and it +was decided that, lacking resources to more fully investigate +the problem, it was better to not punish users of those systems +either by requiring them to work around the problem by hand or +by always substituting an incomplete @code{strtoul()} implementation +when their systems had a complete, working one. +Unfortunately, this meant inconveniencing users of systems not +having @code{strtoul()}, but they're using obsolete (and generally +unsupported) systems anyway. + +@node Object File Differences +@subsubsection Object File Differences +@cindex zzz.o +@cindex zzz.c +@cindex object file, differences +@cindex differences between object files +@cindex make compare + +A comparison of object files after building Stage 3 during a +bootstrap build will result in @file{gcc/f/zzz.o} being flagged +as different from the Stage 2 version. +That is because it +contains a string with an expansion of the @code{__TIME__} macro, +which expands to the current time of day. +It is nothing to worry about, since +@file{gcc/f/zzz.c} doesn't contain any actual code. +It does allow you to override its use of @code{__DATE__} and +@code{__TIME__} by defining macros for the compilation---see the +source code for details. + +@node Cleanup Kills Stage Directories +@subsubsection Cleanup Kills Stage Directories +@cindex stage directories +@cindex make clean + +It'd be helpful if @code{g77}'s @file{Makefile.in} or @file{Make-lang.in} +would create the various @file{stage@var{n}} directories and their +subdirectories, so developers and expert installers wouldn't have to +reconfigure after cleaning up. + +@node Missing gperf? +@subsubsection Missing @code{gperf}? +@cindex @code{gperf} +@cindex missing @code{gperf} + +If a build aborts trying to invoke @code{gperf}, that +strongly suggests an improper method was used to +create the @code{gcc} source directory, +such as the UNIX @samp{cp -r} command instead +of @samp{cp -pr}, since this problem very likely +indicates that the date-time-modified information on +the @code{gcc} source files is incorrect. + +The proper solution is to recreate the @code{gcc} source +directory from a @code{gcc} distribution known to be +provided by the FSF. + +It is possible you might be able to temporarily +work around the problem, however, by trying these +commands: + +@example +sh# @kbd{cd gcc} +sh# @kbd{touch c-gperf.h} +sh# +@end example + +These commands update the date-time-modified information for +the file produced by the invocation of @code{gperf} +in the current versions of @code{gcc}, so that @code{make} no +longer believes it needs to update it. +This file should already exist in a @code{gcc} +distribution, but mistakes made when copying the @code{gcc} +directory can leave the modification information +set such that the @code{gperf} input files look more ``recent'' +than the corresponding output files. + +If the above does not work, definitely start from scratch +and avoid copying the @code{gcc} using any method that does +not reliably preserve date-time-modified information, such +as the UNIX @samp{cp -r} command. + +@node Cross-compiler Problems +@subsection Cross-compiler Problems +@cindex cross-compiler, problems + +@code{g77} has been in alpha testing since September of +1992, and in public beta testing since February of 1995. +Alpha testing was done by a small number of people worldwide on a fairly +wide variety of machines, involving self-compilation in most or +all cases. +Beta testing has been done primarily via self-compilation, +but in more and more cases, cross-compilation (and ``criss-cross +compilation'', where a version of a compiler is built on one machine +to run on a second and generate code that runs on a third) has +been tried and has succeeded, to varying extents. + +Generally, @code{g77} can be ported to any configuration to which +@code{gcc}, @code{f2c}, and @code{libf2c} can be ported and made +to work together, aside from the known problems described in this +manual. +If you want to port @code{g77} to a particular configuration, +you should first make sure @code{gcc} and @code{libf2c} can be +ported to that configuration before focusing on @code{g77}, because +@code{g77} is so dependent on them. + +Even for cases where @code{gcc} and @code{libf2c} work, +you might run into problems with cross-compilation on certain machines, +for several reasons. + +@itemize @bullet +@item +There is one known bug +(a design bug to be fixed in 0.6) that prevents configuration of +@code{g77} as a cross-compiler in some cases, +though there are assumptions made during +configuration that probably make doing non-self-hosting builds +a hassle, requiring manual intervention. + +@item +@code{gcc} might still have some trouble being configured +for certain combinations of machines. +For example, it might not know how to handle floating-point +constants. + +@item +Improvements to the way @code{libf2c} is built could make +building @code{g77} as a cross-compiler easier---for example, +passing and using @samp{LD} and @samp{AR} in the appropriate +ways. + +@item +There are still some challenges putting together the right +run-time libraries (needed by @code{libf2c}) for a target +system, depending on the systems involved in the configuration. +(This is a general problem with cross-compilation, and with +@code{gcc} in particular.) +@end itemize + +@node Settings +@section Changing Settings Before Building + +Here are some internal @code{g77} settings that can be changed +by editing source files in @file{gcc/f/} before building. + +This information, and perhaps even these settings, represent +stop-gap solutions to problems people doing various ports +of @code{g77} have encountered. +As such, none of the following information is expected to +be pertinent in future versions of @code{g77}. + +@menu +* Larger File Unit Numbers:: Raising @samp{MXUNIT}. +* Always Flush Output:: Synchronizing write errors. +* Maximum Stackable Size:: Large arrays are forced off the stack frame. +* Floating-point Bit Patterns:: Possible programs building cross-compiler. +* Large Initialization:: Large arrays with @code{DATA} initialization. +* Alpha Problems Fixed:: Problems 64-bit systems like Alphas now fixed? +@end menu + +@node Larger File Unit Numbers +@subsection Larger File Unit Numbers +@cindex MXUNIT +@cindex unit numbers +@cindex maximum unit number +@cindex illegal unit number +@cindex increasing maximum unit number + +As distributed, whether as part of @code{f2c} or @code{g77}, +@code{libf2c} accepts file unit numbers only in the range +0 through 99. +For example, a statement such as @samp{WRITE (UNIT=100)} causes +a run-time crash in @code{libf2c}, because the unit number, +100, is out of range. + +If you know that Fortran programs at your installation require +the use of unit numbers higher than 99, you can change the +value of the @samp{MXUNIT} macro, which represents the maximum unit +number, to an appropriately higher value. + +To do this, edit the file @file{f/runtime/libI77/fio.h} in your +@code{g77} source tree, changing the following line: + +@example +#define MXUNIT 100 +@end example + +Change the line so that the value of @samp{MXUNIT} is defined to be +at least one @emph{greater} than the maximum unit number used by +the Fortran programs on your system. + +(For example, a program that does @samp{WRITE (UNIT=255)} would require +@samp{MXUNIT} set to at least 256 to avoid crashing.) + +Then build or rebuild @code{g77} as appropriate. + +@emph{Note:} Changing this macro has @emph{no} effect on other limits +your system might place on the number of files open at the same time. +That is, the macro might allow a program to do @samp{WRITE (UNIT=100)}, +but the library and operating system underlying @code{libf2c} might +disallow it if many other files have already been opened (via @code{OPEN} or +implicitly via @code{READ}, @code{WRITE}, and so on). +Information on how to increase these other limits should be found +in your system's documentation. + +@node Always Flush Output +@subsection Always Flush Output +@cindex ALWAYS_FLUSH +@cindex synchronous write errors +@cindex disk full +@cindex flushing output +@cindex fflush() +@cindex I/O, flushing +@cindex output, flushing +@cindex writes, flushing +@cindex NFS +@cindex network file system + +Some Fortran programs require output +(writes) to be flushed to the operating system (under UNIX, +via the @code{fflush()} library call) so that errors, +such as disk full, are immediately flagged via the relevant +@code{ERR=} and @code{IOSTAT=} mechanism, instead of such +errors being flagged later as subsequent writes occur, forcing +the previously written data to disk, or when the file is +closed. + +Essentially, the difference can be viewed as synchronous error +reporting (immediate flagging of errors during writes) versus +asynchronous, or, more precisely, buffered error reporting +(detection of errors might be delayed). + +@code{libf2c} supports flagging write errors immediately when +it is built with the @samp{ALWAYS_FLUSH} macro defined. +This results in a @code{libf2c} that runs slower, sometimes +quite a bit slower, under certain circumstances---for example, +accessing files via the networked file system NFS---but the +effect can be more reliable, robust file I/O. + +If you know that Fortran programs requiring this level of precision +of error reporting are to be compiled using the +version of @code{g77} you are building, you might wish to +modify the @code{g77} source tree so that the version of +@code{libf2c} is built with the @samp{ALWAYS_FLUSH} macro +defined, enabling this behavior. + +To do this, find this line in @file{f/runtime/configure.in} in +your @code{g77} source tree: + +@example +dnl AC_DEFINE(ALWAYS_FLUSH) +@end example + +Remove the leading @samp{dnl@w{ }}, so the line begins with +@samp{AC_DEFINE(}, and run @code{autoconf} in that file's directory. +(Or, if you don't have @code{autoconf}, you can modify @file{f2c.h.in} +in the same directory to include the line @samp{#define ALWAYS_FLUSH} +after @samp{#define F2C_INCLUDE}.) + +Then build or rebuild @code{g77} as appropriate. + +@node Maximum Stackable Size +@subsection Maximum Stackable Size +@vindex FFECOM_sizeMAXSTACKITEM +@cindex code, stack variables +@cindex maximum stackable size +@cindex stack allocation +@cindex segmentation violation +@code{g77}, on most machines, puts many variables and arrays on the stack +where possible, and can be configured (by changing +@samp{FFECOM_sizeMAXSTACKITEM} in @file{gcc/f/com.c}) to force +smaller-sized entities into static storage (saving +on stack space) or permit larger-sized entities to be put on the +stack (which can improve run-time performance, as it presents +more opportunities for the GBE to optimize the generated code). + +@emph{Note:} Putting more variables and arrays on the stack +might cause problems due to system-dependent limits on stack size. +Also, the value of @samp{FFECOM_sizeMAXSTACKITEM} has no +effect on automatic variables and arrays. +@xref{But-bugs}, for more information. + +@node Floating-point Bit Patterns +@subsection Floating-point Bit Patterns + +@cindex cross-compiler, building +@cindex floating-point bit patterns +@cindex bit patterns +The @code{g77} build will crash if an attempt is made to build +it as a cross-compiler +for a target when @code{g77} cannot reliably determine the bit pattern of +floating-point constants for the target. +Planned improvements for g77-0.6 +will give it the capabilities it needs to not have to crash the build +but rather generate correct code for the target. +(Currently, @code{g77} +would generate bad code under such circumstances if it didn't crash +during the build, e.g. when compiling a source file that does +something like @samp{EQUIVALENCE (I,R)} and @samp{DATA R/9.43578/}.) + +@node Large Initialization +@subsection Initialization of Large Aggregate Areas + +@cindex speed, compiler +@cindex slow compiler +@cindex memory utilization +@cindex large initialization +@cindex aggregate initialization +A warning message is issued when @code{g77} sees code that provides +initial values (e.g. via @code{DATA}) to an aggregate area (@code{COMMON} +or @code{EQUIVALENCE}, or even a large enough array or @code{CHARACTER} +variable) +that is large enough to increase @code{g77}'s compile time by roughly +a factor of 10. + +This size currently is quite small, since @code{g77} +currently has a known bug requiring too much memory +and time to handle such cases. +In @file{gcc/f/data.c}, the macro +@samp{FFEDATA_sizeTOO_BIG_INIT_} is defined +to the minimum size for the warning to appear. +The size is specified in storage units, +which can be bytes, words, or whatever, on a case-by-case basis. + +After changing this macro definition, you must +(of course) rebuild and reinstall @code{g77} for +the change to take effect. + +Note that, as of version 0.5.18, improvements have +reduced the scope of the problem for @emph{sparse} +initialization of large arrays, especially those +with large, contiguous uninitialized areas. +However, the warning is issued at a point prior to +when @code{g77} knows whether the initialization is sparse, +and delaying the warning could mean it is produced +too late to be helpful. + +Therefore, the macro definition should not be adjusted to +reflect sparse cases. +Instead, adjust it to generate the warning when densely +initialized arrays begin to cause responses noticeably slower +than linear performance would suggest. + +@node Alpha Problems Fixed +@subsection Alpha Problems Fixed + +@cindex Alpha, support +@cindex 64-bit systems +@code{g77} used to warn when it was used to compile Fortran code +for a target configuration that is not basically a 32-bit +machine (such as an Alpha, which is a 64-bit machine, especially +if it has a 64-bit operating system running on it). +That was because @code{g77} was known to not work +properly on such configurations. + +As of version 0.5.20, @code{g77} is believed to work well +enough on such systems. +So, the warning is no longer needed or provided. + +However, support for 64-bit systems, especially in +areas such as cross-compilation and handling of +intrinsics, is still incomplete. +The symptoms +are believed to be compile-time diagnostics rather +than the generation of bad code. +It is hoped that version 0.6 will completely support 64-bit +systems. + +@node Quick Start +@section Quick Start +@cindex quick start + +This procedure configures, builds, and installs @code{g77} +``out of the box'' and works on most UNIX systems. +Each command is identified by a unique number, +used in the explanatory text that follows. +For the most part, the output of each command is not shown, +though indications of the types of responses are given in a +few cases. + +To perform this procedure, the installer must be logged +in as user @code{root}. +Much of it can be done while not logged in as @code{root}, +and users experienced with UNIX administration should be +able to modify the procedure properly to do so. + +Following traditional UNIX conventions, it is assumed that +the source trees for @code{g77} and @code{gcc} will be +placed in @file{/usr/src}. +It also is assumed that the source distributions themselves +already reside in @file{/usr/FSF}, a naming convention +used by the author of @code{g77} on his own system: + +@example +/usr/FSF/gcc-2.7.2.2.tar.gz +/usr/FSF/g77-0.5.21.tar.gz +@end example + +@c (You can use @file{gcc-2.7.2.1.tar.gz} instead, or +@c the equivalent of it obtained by applying the +@c patch distributed as @file{gcc-2.7.2-2.7.2.1.diff.gz} +@c to version 2.7.2 of @code{gcc}, +@c if you remember to make the appropriate adjustments in the +@c instructions below.) + +@cindex SunOS4 +Users of the following systems should not blindly follow +these quick-start instructions, because of problems their +systems have coping with straightforward installation of +@code{g77}: + +@itemize @bullet +@item +SunOS4 +@end itemize + +Instead, see @ref{Complete Installation}, for detailed information +on how to configure, build, and install @code{g77} for your +particular system. +Also, see @ref{Trouble,,Known Causes of Trouble with GNU Fortran}, +for information on bugs and other problems known to afflict the +installation process, and how to report newly discovered ones. + +If your system is @emph{not} on the above list, and @emph{is} +a UNIX system or one of its variants, you should be able to +follow the instructions below. +If you vary @emph{any} of the steps below, you might run into +trouble, including possibly breaking existing programs for +other users of your system. +Before doing so, it is wise to review the explanations of some +of the steps. +These explanations follow this list of steps. + +@example +sh[ 1]# @kbd{cd /usr/src} +@set source-dir 1 +sh[ 2]# @kbd{gunzip -c < /usr/FSF/gcc-2.7.2.2.tar.gz | tar xf -} +[Might say "Broken pipe"...that is normal on some systems.] +@set unpack-gcc 2 +sh[ 3]# @kbd{gunzip -c < /usr/FSF/g77-0.5.21.tar.gz | tar xf -} +["Broken pipe" again possible.] +@set unpack-g77 3 +sh[ 4]# @kbd{ln -s gcc-2.7.2.2 gcc} +@set link-gcc 4 +sh[ 5]# @kbd{ln -s g77-0.5.21 g77} +@set link-g77 5 +sh[ 6]# @kbd{mv -i g77/* gcc} +[No questions should be asked by mv here; or, you made a mistake.] +@set merge-g77 6 +sh[ 7]# @kbd{patch -p1 -V t -d gcc < gcc/f/gbe/2.7.2.2.diff} +[Unless patch complains about rejected patches, this step worked.] +@set apply-patch 7 +sh[ 8]# @kbd{cd gcc} +sh[ 9]# @kbd{touch f77-install-ok} +[Do not do the above if your system already has an f77 +command, unless you've checked that overwriting it +is okay.] +@set f77-install-ok 9 +sh[10]# @kbd{touch f2c-install-ok} +[Do not do the above if your system already has an f2c +command, unless you've checked that overwriting it +is okay. Else, @kbd{touch f2c-exists-ok}.] +@set f2c-install-ok 10 +sh[11]# @kbd{./configure --prefix=/usr} +[Do not do the above if gcc is not installed in /usr/bin. +You might need a different @kbd{--prefix=@dots{}}, as +described below.] +@set configure-gcc 11 +sh[12]# @kbd{make bootstrap} +[This takes a long time, and is where most problems occur.] +@set build-gcc 12 +sh[13]# @kbd{make compare} +[This verifies that the compiler is `sane'. Only +the file `f/zzz.o' (aka `tmp-foo1' and `tmp-foo2') +should be in the list of object files this command +prints as having different contents. If other files +are printed, you have likely found a g77 bug.] +@set compare-gcc 13 +sh[14]# @kbd{rm -fr stage1} +@set rm-stage1 14 +sh[15]# @kbd{make -k install} +[The actual installation.] +@set install-g77 15 +sh[16]# @kbd{g77 -v} +[Verify that g77 is installed, obtain version info.] +@set show-version 16 +sh[17]# +@set end-procedure 17 +@end example + +@xref{Updating Documentation,,Updating Your Info Directory}, for +information on how to update your system's top-level @code{info} +directory to contain a reference to this manual, so that +users of @code{g77} can easily find documentation instead +of having to ask you for it. + +Elaborations of many of the above steps follows: + +@table @asis +@item Step @value{source-dir}: @kbd{cd /usr/src} +You can build @code{g77} pretty much anyplace. +By convention, this manual assumes @file{/usr/src}. +It might be helpful if other users on your system +knew where to look for the source code for the +installed version of @code{g77} and @code{gcc} in any case. + +@c @item Step @value{unpack-gcc}: @kbd{gunzip -d @dots{}} +@c Here, you might wish to use @file{gcc-2.7.2.1.tar.gz} +@c instead, or apply @file{gcc-2.7.2-2.7.2.1.diff.gz} to achieve +@c similar results. + +@item Step @value{unpack-g77}: @kbd{gunzip -d < /usr/FSF/g77-0.5.21.tar.gz | tar xf -} +It is not always necessary to obtain the latest version of +@code{g77} as a complete @file{.tar.gz} file if you have +a complete, earlier distribution of @code{g77}. +If appropriate, you can unpack that earlier +version of @code{g77}, and then apply the appropriate patches +to achieve the same result---a source tree containing version +0.5.21 of @code{g77}. + +@item Step @value{link-gcc}: @kbd{ln -s gcc-2.7.2.2 gcc} +@item Step @value{link-g77}: @kbd{ln -s g77-0.5.21 g77} +These commands mainly help reduce typing, +and help reduce visual clutter in examples +in this manual showing what to type to install @code{g77}. + +@c Of course, if appropriate, @kbd{ln -s gcc-2.7.2.1 gcc} or +@c similar. + +@xref{Unpacking}, for information on +using distributions of @code{g77} made by organizations +other than the FSF. + +@item Step @value{merge-g77}: @kbd{mv -i g77/* gcc} +After doing this, you can, if you like, type +@samp{rm g77} and @samp{rmdir g77-0.5.21} to remove +the empty directory and the symbol link to it. +But, it might be helpful to leave them around as +quick reminders of which version(s) of @code{g77} are +installed on your system. + +@xref{Unpacking}, for information +on the contents of the @file{g77} directory (as merged +into the @file{gcc} directory). + +@item Step @value{apply-patch}: @kbd{patch -p1 @dots{}} +@c (Or `@kbd{@dots{} < gcc/f/gbe/2.7.2.1.diff}', if appropriate.) +@c +This can produce a wide variety of printed output, +from @samp{Hmm, I can't seem to find a patch in there anywhere...} +to long lists of messages indicated that patches are +being found, applied successfully, and so on. + +If messages about ``fuzz'', ``offset'', or +especially ``reject files'' are printed, it might +mean you applied the wrong patch file. +If you believe this is the case, it is best to restart +the sequence after deleting (or at least renaming to unused +names) the top-level directories for @code{g77} and @code{gcc} +and their symbolic links. + +After this command finishes, the @code{gcc} directory might +have old versions of several files as saved by @code{patch}. +To remove these, after @kbd{cd gcc}, type @kbd{rm -i *.~*~}. + +@xref{Merging Distributions}, for more information. + +@item Step @value{f77-install-ok}: @kbd{touch f77-install-ok} +Don't do this if you don't want to overwrite an existing +version of @code{f77} (such as a native compiler, or a +script that invokes @code{f2c}). +Otherwise, installation will overwrite the @code{f77} command +and the @code{f77} man pages with copies of the corresponding +@code{g77} material. + +@xref{Installing f77,,Installing @code{f77}}, for more +information. + +@item Step @value{f2c-install-ok}: @kbd{touch f2c-install-ok} +Don't do this if you don't want to overwrite an existing +installation of @code{libf2c} (though, chances are, you do). +Instead, @kbd{touch f2c-exists-ok} to allow the installation +to continue without any error messages about @file{/usr/lib/libf2c.a} +already existing. + +@xref{Installing f2c,,Installing @code{f2c}}, for more +information. + +@item Step @value{configure-gcc}: @kbd{./configure --prefix=/usr} +This is where you specify that the @file{g77} executable is to be +installed in @file{/usr/bin/}, the @file{libf2c.a} library is +to be installed in @file{/usr/lib/}, and so on. + +You should ensure that any existing installation of the @file{gcc} +executable is in @file{/usr/bin/}. +Otherwise, installing @code{g77} so that it does not fully +replace the existing installation of @code{gcc} is likely +to result in the inability to compile Fortran programs. + +@xref{Where to Install,,Where in the World Does Fortran (and GNU CC) Go?}, +for more information on determining where to install @code{g77}. +@xref{Configuring gcc}, for more information on the +configuration process triggered by invoking the @file{./configure} +script. + +@item Step @value{build-gcc}: @kbd{make bootstrap} +@xref{Installation,,Installing GNU CC, +gcc,Using and Porting GNU CC}, for information +on the kinds of diagnostics you should expect during +this procedure. + +@xref{Building gcc}, for complete @code{g77}-specific +information on this step. + +@item Step @value{compare-gcc}: @kbd{make compare} +@xref{Bug Lists,,Where to Port Bugs}, for information +on where to report that you observed more than +@file{f/zzz.o} having different contents during this +phase. + +@xref{Bug Reporting,,How to Report Bugs}, for +information on @emph{how} to report bugs like this. + +@item Step @value{rm-stage1}: @kbd{rm -fr stage1} +You don't need to do this, but it frees up disk space. + +@item Step @value{install-g77}: @kbd{make -k install} +If this doesn't seem to work, try: + +@example +make -k install install-libf77 install-f2c-all +@end example + +@xref{Installation of Binaries}, for more information. + +@xref{Updating Documentation,,Updating Your Info Directory}, +for information on entering this manual into your +system's list of texinfo manuals. + +@item Step @value{show-version}: @kbd{g77 -v} +If this command prints approximately 25 lines of output, +including the GNU Fortran Front End version number (which +should be the same as the version number for the version +of @code{g77} you just built and installed) and the +version numbers for the three parts of the @code{libf2c} +library (@code{libF77}, @code{libI77}, @code{libU77}), and +those version numbers are all in agreement, then there is +a high likelihood that the installation has been successfully +completed. + +You might consider doing further testing. +For example, log in as a non-privileged user, then create +a small Fortran program, such as: + +@example + PROGRAM SMTEST + DO 10 I=1, 10 + PRINT *, 'Hello World #', I +10 CONTINUE + END +@end example + +Compile, link, and run the above program, and, assuming you named +the source file @file{smtest.f}, the session should look like this: + +@example +sh# @kbd{g77 -o smtest smtest.f} +sh# @kbd{./smtest} + Hello World # 1 + Hello World # 2 + Hello World # 3 + Hello World # 4 + Hello World # 5 + Hello World # 6 + Hello World # 7 + Hello World # 8 + Hello World # 9 + Hello World # 10 +sh# +@end example + +After proper installation, you don't +need to keep your gcc and g77 source and build directories +around anymore. +Removing them can free up a lot of disk space. +@end table + +@node Complete Installation +@section Complete Installation + +Here is the complete @code{g77}-specific information on how +to configure, build, and install @code{g77}. + +@menu +* Unpacking:: +* Merging Distributions:: +* f77: Installing f77. +* f2c: Installing f2c. +* Patching GNU Fortran:: +* Where to Install:: +* Configuring gcc:: +* Building gcc:: +* Pre-installation Checks:: +* Installation of Binaries:: +* Updating Documentation:: +* bison: Missing bison?. +* makeinfo: Missing makeinfo?. +@end menu + +@node Unpacking +@subsection Unpacking +@cindex unpacking distributions +@cindex distributions, unpacking +@cindex code, source +@cindex source code +@cindex source tree +@cindex packages + +The @code{gcc} source distribution is a stand-alone distribution. +It is designed to be unpacked (producing the @code{gcc} +source tree) and built as is, assuming certain +prerequisites are met (including the availability of compatible +UNIX programs such as @code{make}, @code{cc}, and so on). + +However, before building @code{gcc}, you will want to unpack +and merge the @code{g77} distribution in with it, so that you +build a Fortran-capable version of @code{gcc}, which includes +the @code{g77} command, the necessary run-time libraries, +and this manual. + +Unlike @code{gcc}, the @code{g77} source distribution +is @emph{not} a stand-alone distribution. +It is designed to be unpacked and, afterwards, immediately merged +into an applicable @code{gcc} source tree. +That is, the @code{g77} distribution @emph{augments} a +@code{gcc} distribution---without @code{gcc}, generally +only the documentation is immediately usable. + +A sequence of commands typically used to unpack @code{gcc} +and @code{g77} is: + +@example +sh# @kbd{cd /usr/src} +sh# @kbd{gunzip -d < /usr/FSF/gcc-2.7.2.2.tar.gz | tar xf -} +sh# @kbd{gunzip -d < /usr/FSF/g77-0.5.21.tar.gz | tar xf -} +sh# @kbd{ln -s gcc-2.7.2.2 gcc} +sh# @kbd{ln -s g77-0.5.21 g77} +sh# @kbd{mv -i g77/* gcc} +@end example + +@emph{Notes:} The commands beginning with @samp{gunzip@dots{}} might +print @samp{Broken pipe@dots{}} as they complete. +That is nothing to worry about, unless you actually +@emph{hear} a pipe breaking. +The @code{ln} commands are helpful in reducing typing +and clutter in installation examples in this manual. +Hereafter, the top level of @code{gcc} source tree is referred to +as @file{gcc}, and the top level of just the @code{g77} +source tree (prior to issuing the @code{mv} command, above) +is referred to as @file{g77}. + +There are three top-level names in a @code{g77} distribution: + +@example +g77/COPYING.g77 +g77/README.g77 +g77/f +@end example + +All three entries should be moved (or copied) into a @code{gcc} +source tree (typically named after its version number and +as it appears in the FSF distributions---e.g. @file{gcc-2.7.2.2}). + +@file{g77/f} is the subdirectory containing all of the +code, documentation, and other information that is specific +to @code{g77}. +The other two files exist to provide information on @code{g77} +to someone encountering a @code{gcc} source tree with @code{g77} +already present, who has not yet read these installation +instructions and thus needs help understanding that the +source tree they are looking at does not come from a single +FSF distribution. +They also help people encountering an unmerged @code{g77} source +tree for the first time. + +@cindex modifying @code{g77} +@cindex code, modifying +@cindex Pentium optimizations +@cindex optimizations, Pentium +@emph{Note:} Please use @strong{only} @code{gcc} and @code{g77} +source trees as distributed by the FSF. +Use of modified versions, such as the Pentium-specific-optimization +port of @code{gcc}, is likely to result in problems that appear to be +in the @code{g77} code but, in fact, are not. +Do not use such modified versions +unless you understand all the differences between them and the versions +the FSF distributes---in which case you should be able to modify the +@code{g77} (or @code{gcc}) source trees appropriately so @code{g77} +and @code{gcc} can coexist as they do in the stock FSF distributions. + +@node Merging Distributions +@subsection Merging Distributions +@cindex merging distributions +@cindex @code{gcc} versions supported by @code{g77} +@cindex versions of @code{gcc} +@cindex support for @code{gcc} versions + +After merging the @code{g77} source tree into the @code{gcc} +source tree, the final merge step is done by applying the +pertinent patches the @code{g77} distribution provides for +the @code{gcc} source tree. + +Read the file @file{gcc/f/gbe/README}, and apply the appropriate +patch file for the version of the GNU CC compiler you have, if +that exists. +If the directory exists but the appropriate file +does not exist, you are using either an old, unsupported version, +or a release one that is newer than the newest @code{gcc} version +supported by the version of @code{g77} you have. + +@cindex gcc version numbering +@cindex version numbering +@cindex g77 version number +@cindex GNU version numbering +As of version 0.5.18, @code{g77} modifies the version number +of @code{gcc} via the pertinent patches. +This is done because the resulting version of @code{gcc} is +deemed sufficiently different from the vanilla distribution +to make it worthwhile to present, to the user, information +signaling the fact that there are some differences. + +GNU version numbers make it easy to figure out whether a +particular version of a distribution is newer or older than +some other version of that distribution. +The format is, +generally, @var{major}.@var{minor}.@var{patch}, with +each field being a decimal number. +(You can safely ignore +leading zeros; for example, 1.5.3 is the same as 1.5.03.)@ +The @var{major} field only increases with time. +The other two fields are reset to 0 when the field to +their left is incremented; otherwise, they, too, only +increase with time. +So, version 2.6.2 is newer than version 2.5.8, and +version 3.0 is newer than both. +(Trailing @samp{.0} fields often are omitted in +announcements and in names for distributions and +the directories they create.) + +If your version of @code{gcc} is older than the oldest version +supported by @code{g77} (as casually determined by listing +the contents of @file{gcc/f/gbe/}), you should obtain a newer, +supported version of @code{gcc}. +(You could instead obtain an older version of @code{g77}, +or try and get your @code{g77} to work with the old +@code{gcc}, but neither approach is recommended, and +you shouldn't bother reporting any bugs you find if you +take either approach, because they're probably already +fixed in the newer versions you're not using.) + +If your version of @code{gcc} is newer than the newest version +supported by @code{g77}, it is possible that your @code{g77} +will work with it anyway. +If the version number for @code{gcc} differs only in the +@var{patch} field, you might as well try applying the @code{g77} patch +that is for the newest version of @code{gcc} having the same +@var{major} and @var{minor} fields, as this is likely to work. + +So, for example, if a particular version of @code{g77} has support for +@code{gcc} versions 2.7.0 and 2.7.1, +it is likely that @file{gcc-2.7.2} would work well with @code{g77} +by using the @file{2.7.1.diff} patch file provided +with @code{g77} (aside from some offsets reported by @code{patch}, +which usually are harmless). + +However, @file{gcc-2.8.0} would almost certainly +not work with that version of @code{g77} no matter which patch file was +used, so a new version of @code{g77} would be needed (and you should +wait for it rather than bothering the maintainers---@pxref{Changes,, +User-Visible Changes}). + +@cindex distributions, why separate +@cindex separate distributions +@cindex why separate distributions +This complexity is the result of @code{gcc} and @code{g77} being +separate distributions. +By keeping them separate, each product is able to be independently +improved and distributed to its user base more frequently. + +However, @code{g77} often requires changes to contemporary +versions of @code{gcc}. +Also, the GBE interface defined by @code{gcc} typically +undergoes some incompatible changes at least every time the +@var{minor} field of the version number is incremented, +and such changes require corresponding changes to +the @code{g77} front end (FFE). + +It is hoped that the GBE interface, and the @code{gcc} and +@code{g77} products in general, will stabilize sufficiently +for the need for hand-patching to disappear. + +Invoking @code{patch} as described in @file{gcc/f/gbe/README} +can produce a wide variety of printed output, +from @samp{Hmm, I can't seem to find a patch in there anywhere...} +to long lists of messages indicated that patches are +being found, applied successfully, and so on. + +If messages about ``fuzz'', ``offset'', or +especially ``reject files'' are printed, it might +mean you applied the wrong patch file. +If you believe this is the case, it is best to restart +the sequence after deleting (or at least renaming to unused +names) the top-level directories for @code{g77} and @code{gcc} +and their symbolic links. +That is because @code{patch} might have partially patched +some @code{gcc} source files, so reapplying the correct +patch file might result in the correct patches being +applied incorrectly (due to the way @code{patch} necessarily +works). + +After @code{patch} finishes, the @code{gcc} directory might +have old versions of several files as saved by @code{patch}. +To remove these, after @kbd{cd gcc}, type @kbd{rm -i *.~*~}. + +@pindex config-lang.in +@emph{Note:} @code{g77}'s configuration file @file{gcc/f/config-lang.in} +ensures that the source code for the version of @code{gcc} +being configured has at least one indication of being patched +as required specifically by @code{g77}. +This configuration-time +checking should catch failure to apply the correct patch and, +if so caught, should abort the configuration with an explanation. +@emph{Please} do not try to disable the check, +otherwise @code{g77} might well appear to build +and install correctly, and even appear to compile correctly, +but could easily produce broken code. + +@cindex creating patch files +@cindex patch files, creating +@pindex gcc/f/gbe/ +@samp{diff -rcp2N} is used to create the patch files +in @file{gcc/f/gbe/}. + +@node Installing f77 +@subsection Installing @code{f77} +@cindex f77 command +@cindex commands, f77 +@cindex native compiler + +You should decide whether you want installation of @code{g77} +to also install an @code{f77} command. +On systems with a native @code{f77}, this is not +normally desired, so @code{g77} does not do this by +default. + +@pindex f77-install-ok +@vindex F77_INSTALL_FLAG +If you want @code{f77} installed, create the file @file{f77-install-ok} +(e.g. via the UNIX command @samp{touch f77-install-ok}) in the +source or build top-level directory (the same directory in +which the @code{g77} @file{f} directory resides, not the @file{f} directory +itself), or edit @file{gcc/f/Make-lang.in} and change the definition +of the @samp{F77_INSTALL_FLAG} macro appropriately. + +Usually, this means that, after typing @samp{cd gcc}, you +would type @samp{touch f77-install-ok}. + +When you enable installation of @code{f77}, either a link to or a +direct copy of the @code{g77} command is made. +Similarly, @file{f77.1} is installed as a man page. + +(The @code{uninstall} target in the @file{gcc/Makefile} also tests +this macro and file, when invoked, to determine whether to delete the +installed copies of @code{f77} and @file{f77.1}.) + +@emph{Note:} No attempt is yet made +to install a program (like a shell script) that provides +compatibility with any other @code{f77} programs. +Only the most rudimentary invocations of @code{f77} will +work the same way with @code{g77}. + +@node Installing f2c +@subsection Installing @code{f2c} + +Currently, @code{g77} does not include @code{f2c} itself in its +distribution. +However, it does include a modified version of the @code{libf2c}. +This version is normally compatible with @code{f2c}, but has been +modified to meet the needs of @code{g77} in ways that might possibly +be incompatible with some versions or configurations of @code{f2c}. + +Decide how installation of @code{g77} should affect any existing installation +of @code{f2c} on your system. + +@pindex f2c +@pindex f2c.h +@pindex libf2c.a +@pindex libF77.a +@pindex libI77.a +If you do not have @code{f2c} on your system (e.g. no @file{/usr/bin/f2c}, +no @file{/usr/include/f2c.h}, and no @file{/usr/lib/libf2c.a}, +@file{/usr/lib/libF77.a}, or @file{/usr/lib/libI77.a}), you don't need to +be concerned with this item. + +If you do have @code{f2c} on your system, you need to decide how users +of @code{f2c} will be affected by your installing @code{g77}. +Since @code{g77} is +currently designed to be object-code-compatible with @code{f2c} (with +very few, clear exceptions), users of @code{f2c} might want to combine +@code{f2c}-compiled object files with @code{g77}-compiled object files in a +single executable. + +To do this, users of @code{f2c} should use the same copies of @file{f2c.h} and +@file{libf2c.a} that @code{g77} uses (and that get built as part of +@code{g77}). + +If you do nothing here, the @code{g77} installation process will not +overwrite the @file{include/f2c.h} and @file{lib/libf2c.a} files with its +own versions, and in fact will not even install @file{libf2c.a} for use +with the newly installed versions of @code{gcc} and @code{g77} if it sees +that @file{lib/libf2c.a} exists---instead, it will print an explanatory +message and skip this part of the installation. + +@pindex f2c-install-ok +@vindex F2C_INSTALL_FLAG +To install @code{g77}'s versions of @file{f2c.h} and @file{libf2c.a} +in the appropriate +places, create the file @file{f2c-install-ok} (e.g. via the UNIX +command @samp{touch f2c-install-ok}) in the source or build top-level +directory (the same directory in which the @code{g77} @file{f} directory +resides, not the @file{f} directory itself), or edit @file{gcc/f/Make-lang.in} +and change the definition of the @samp{F2C_INSTALL_FLAG} macro appropriately. + +Usually, this means that, after typing @samp{cd gcc}, you +would type @samp{touch f2c-install-ok}. + +Make sure that when you enable the overwriting of @file{f2c.h} +and @file{libf2c.a} +as used by @code{f2c}, you have a recent and properly configured version of +@file{bin/f2c} so that it generates code that is compatible with @code{g77}. + +@pindex f2c-exists-ok +@vindex F2CLIBOK +If you don't want installation of @code{g77} to overwrite @code{f2c}'s existing +installation, but you do want @code{g77} installation to proceed with +installation of its own versions of @file{f2c.h} and @file{libf2c.a} in places +where @code{g77} will pick them up (even when linking @code{f2c}-compiled +object files---which might lead to incompatibilities), create +the file @file{f2c-exists-ok} (e.g. via the UNIX command +@samp{touch f2c-exists-ok}) in the source or build top-level directory, +or edit @file{gcc/f/Make-lang.in} and change the definition of the +@samp{F2CLIBOK} macro appropriately. + +@node Patching GNU Fortran +@subsection Patching GNU Fortran + +If you're using a SunOS4 system, you'll need to make the following +change to @file{gcc/f/proj.h}: edit the line reading + +@example +#define FFEPROJ_STRTOUL 1 @dots{} +@end example + +@noindent +by replacing the @samp{1} with @samp{0}. +Or, you can avoid editing the source by adding +@example +CFLAGS='-DFFEPROJ_STRTOUL=0 -g -O' +@end example +to the command line for @code{make} when you invoke it. +(@samp{-g} is the default for @samp{CFLAGS}.) + +This causes a minimal version of @code{strtoul()} provided +as part of the @code{g77} distribution to be compiled and +linked into whatever @code{g77} programs need it, since +some systems (like SunOS4 with only the bundled compiler and its +runtime) do not provide this function in their system libraries. + +Similarly, a minimal version of @code{bsearch()} is available +and can be enabled by editing a line similar to the one +for @code{strtoul()} above in @file{gcc/f/proj.h}, if +your system libraries lack @code{bsearch()}. +The method of overriding @samp{X_CFLAGS} may also be used. + +These are not problems with @code{g77}, which requires an +ANSI C environment. +You should upgrade your system to one that provides +a full ANSI C environment, or encourage the maintainers +of @code{gcc} to provide one to all @code{gcc}-based +compilers in future @code{gcc} distributions. + +@xref{Problems Installing}, for more information on +why @code{strtoul()} comes up missing and on approaches +to dealing with this problem that have already been tried. + +@node Where to Install +@subsection Where in the World Does Fortran (and GNU CC) Go? +@cindex language f77 not recognized +@cindex gcc will not compile Fortran programs + +Before configuring, you should make sure you know +where you want the @code{g77} and @code{gcc} +binaries to be installed after they're built, +because this information is given to the configuration +tool and used during the build itself. + +A @code{g77} installation necessarily requires installation of +a @code{g77}-aware version of @code{gcc}, so that the @code{gcc} +command recognizes Fortran source files and knows how to compile +them. + +For this to work, the version of @code{gcc} that you will be building +as part of @code{g77} @strong{must} be installed as the ``active'' +version of @code{gcc} on the system. + +Sometimes people make the mistake of installing @code{gcc} as +@file{/usr/local/bin/gcc}, +leaving an older, non-Fortran-aware version in @file{/usr/bin/gcc}. +(Or, the opposite happens.)@ +This can result in @code{g77} being unable to compile Fortran +source files, because when it calls on @code{gcc} to do the +actual compilation, @code{gcc} complains that it does not +recognize the language, or the file name suffix. + +So, determine whether @code{gcc} already is installed on your system, +and, if so, @emph{where} it is installed, and prepare to configure the +new version of @code{gcc} you'll be building so that it installs +over the existing version of @code{gcc}. + +You might want to back up your existing copy of @file{bin/gcc}, and +the entire @file{lib/} directory, before +you perform the actual installation (as described in this manual). + +Existing @code{gcc} installations typically are +found in @file{/usr} or @file{/usr/local}. +If you aren't certain where the currently +installed version of @code{gcc} and its +related programs reside, look at the output +of this command: + +@example +gcc -v -o /tmp/delete-me -xc /dev/null -xnone +@end example + +All sorts of interesting information on the locations of various +@code{gcc}-related programs and data files should be visible +in the output of the above command. +(The output also is likely to include a diagnostic from +the linker, since there's no @samp{main_()} function.) +However, you do have to sift through it yourself; @code{gcc} +currently provides no easy way to ask it where it is installed +and where it looks for the various programs and data files it +calls on to do its work. + +Just @emph{building} @code{g77} should not overwrite any installed +programs---but, usually, after you build @code{g77}, you will want +to install it, so backing up anything it might overwrite is +a good idea. +(This is true for any package, not just @code{g77}, +though in this case it is intentional that @code{g77} overwrites +@code{gcc} if it is already installed---it is unusual that +the installation process for one distribution intentionally +overwrites a program or file installed by another distribution.) + +Another reason to back up the existing version first, +or make sure you can restore it easily, is that it might be +an older version on which other users have come to depend +for certain behaviors. +However, even the new version of @code{gcc} you install +will offer users the ability to specify an older version of +the actual compilation programs if desired, and these +older versions need not include any @code{g77} components. +@xref{Target Options,,Specifying Target Machine and Compiler Version, +gcc,Using and Porting GNU CC}, for information on the @samp{-V} +option of @code{gcc}. + +@node Configuring gcc +@subsection Configuring GNU CC + +@code{g77} is configured automatically when you configure +@code{gcc}. +There are two parts of @code{g77} that are configured in two +different ways---@code{g77}, which ``camps on'' to the +@code{gcc} configuration mechanism, and @code{libf2c}, which +uses a variation of the GNU @code{autoconf} configuration +system. + +Generally, you shouldn't have to be concerned with +either @code{g77} or @code{libf2c} configuration, unless +you're configuring @code{g77} as a cross-compiler. +In this case, the @code{libf2c} configuration, and possibly the +@code{g77} and @code{gcc} configurations as well, +might need special attention. +(This also might be the case if you're porting @code{gcc} to +a whole new system---even if it is just a new operating system +on an existing, supported CPU.) + +To configure the system, see +@ref{Installation,,Installing GNU CC,gcc,Using and Porting GNU CC}, +following the instructions for running @file{./configure}. +Pay special attention to the @samp{--prefix=} option, which +you almost certainly will need to specify. + +(Note that @code{gcc} installation information is provided +as a straight text file in @file{gcc/INSTALL}.) + +The information printed by the invocation of @file{./configure} +should show that the @file{f} directory (the Fortran language) +has been configured. +If it does not, there is a problem. + +@emph{Note:} Configuring with the @samp{--srcdir} argument is known +to work with GNU @code{make}, but it is not known to work with +other variants of @code{make}. +Irix5.2 and SunOS4.1 versions of @code{make} definitely +won't work outside the source directory at present. +@code{g77}'s +portion of the @file{configure} script issues a warning message +about this when you configure for building binaries outside +the source directory. + +@node Building gcc +@subsection Building GNU CC +@cindex building @code{gcc} +@cindex building @code{g77} + +@vindex LANGUAGES +Building @code{g77} requires building enough of @code{gcc} that +these instructions assume you're going to build all of +@code{gcc}, including @code{g++}, @code{protoize}, and so on. +You can save a little time and disk space by changes the +@samp{LANGUAGES} macro definition in @code{gcc/Makefile.in} +or @code{gcc/Makefile}, but if you do that, you're on your own. +One change is almost @emph{certainly} going to cause failures: +removing @samp{c} or @samp{f77} from the definition of the +@samp{LANGUAGES} macro. + +After configuring @code{gcc}, which configures @code{g77} and +@code{libf2c} automatically, you're ready to start the actual +build by invoking @code{make}. + +@pindex configure +@emph{Note:} You @strong{must} have run @file{./configure} +before you run @code{make}, even if you're +using an already existing @code{gcc} development directory, because +@file{./configure} does the work to recognize that you've added +@code{g77} to the configuration. + +There are two general approaches to building GNU CC from +scratch: + +@table @dfn +@item bootstrap +This method uses minimal native system facilities to +build a barebones, unoptimized @code{gcc}, that is then +used to compile (``bootstrap'') the entire system. + +@item straight +This method assumes a more complete native system +exists, and uses that just once to build the entire +system. +@end table + +On all systems without a recent version of @code{gcc} +already installed, the @i{bootstrap} method must be +used. +In particular, @code{g77} uses extensions to the C +language offered, apparently, only by @code{gcc}. + +On most systems with a recent version of @code{gcc} +already installed, the @i{straight} method can be +used. +This is an advantage, because it takes less CPU time +and disk space for the build. +However, it does require that the system have fairly +recent versions of many GNU programs and other +programs, which are not enumerated here. + +@menu +* Bootstrap Build:: For all systems. +* Straight Build:: For systems with a recent version of @code{gcc}. +@end menu + +@node Bootstrap Build +@subsubsection Bootstrap Build +@cindex bootstrap build +@cindex build, bootstrap + +A complete bootstrap build is done by issuing a command +beginning with @samp{make bootstrap @dots{}}, as +described in @ref{Installation,,Installing GNU CC, +gcc,Using and Porting GNU CC}. +This is the most reliable form of build, but it does require +the most disk space and CPU time, since the complete system +is built twice (in Stages 2 and 3), after an initial build +(during Stage 1) of a minimal @code{gcc} compiler using +the native compiler and libraries. + +You might have to, or want to, control the way a bootstrap +build is done by entering the @code{make} commands to build +each stage one at a time, as described in the @code{gcc} +manual. +For example, to save time or disk space, you might want +to not bother doing the Stage 3 build, in which case you +are assuming that the @code{gcc} compiler you have built +is basically sound (because you are giving up the opportunity +to compare a large number of object files to ensure they're +identical). + +To save some disk space during installation, after Stage 2 +is built, you can type @samp{rm -fr stage1} to remove the +binaries built during Stage 1. + +@emph{Note:} @xref{Object File Differences}, for information on +expected differences in object files produced during Stage 2 and +Stage 3 of a bootstrap build. +These differences will be encountered as a result of using +the @samp{make compare} or similar command sequence recommended +by the GNU CC installation documentation. + +Also, @xref{Installation,,Installing GNU CC,gcc,Using and Porting GNU CC}, +for important information on building @code{gcc} that is +not described in this @code{g77} manual. +For example, explanations of diagnostic messages +and whether they're expected, or indicate trouble, +are found there. + +@node Straight Build +@subsubsection Straight Build +@cindex straight build +@cindex build, straight + +If you have a recent version of @code{gcc} +already installed on your system, and if you're +reasonably certain it produces code that is +object-compatible with the version of @code{gcc} +you want to build as part of building @code{g77}, +you can save time and disk space by doing a straight +build. + +To build just the C and Fortran compilers and the +necessary run-time libraries, issue the following +command: + +@example +make -k CC=gcc LANGUAGES=f77 all g77 +@end example + +(The @samp{g77} target is necessary because the @code{gcc} +build procedures apparently do not automatically build +command drivers for languages in subdirectories. +It's the @samp{all} target that triggers building +everything except, apparently, the @code{g77} command +itself.) + +If you run into problems using this method, you have +two options: + +@itemize @bullet +@item +Abandon this approach and do a bootstrap build. + +@item +Try to make this approach work by diagnosing the +problems you're running into and retrying. +@end itemize + +Especially if you do the latter, you might consider +submitting any solutions as bug/fix reports. +@xref{Trouble,,Known Causes of Trouble with GNU Fortran}. + +However, understand that many problems preventing a +straight build from working are not @code{g77} problems, +and, in such cases, are not likely to be addressed in +future versions of @code{g77}. + +@node Pre-installation Checks +@subsection Pre-installation Checks +@cindex pre-installation checks +@cindex installing, checking before + +Before installing the system, which includes installing +@code{gcc}, you might want to do some minimum checking +to ensure that some basic things work. + +Here are some commands you can try, and output typically +printed by them when they work: + +@example +sh# @kbd{cd /usr/src/gcc} +sh# @kbd{./g77 --driver=./xgcc -B./ -v} +g77 version 0.5.21 + ./xgcc -B./ -v -fnull-version -o /tmp/gfa18047 @dots{} +Reading specs from ./specs +gcc version 2.7.2.2.f.3 + ./cpp -lang-c -v -isystem ./include -undef @dots{} +GNU CPP version 2.7.2.2.f.3 (Linux/Alpha) +#include "..." search starts here: +#include <...> search starts here: + ./include + /usr/local/include + /usr/alpha-unknown-linux/include + /usr/lib/gcc-lib/alpha-unknown-linux/2.7.2.2.f.3/include + /usr/include +End of search list. + ./f771 /tmp/cca18048.i -fset-g77-defaults -quiet -dumpbase @dots{} +GNU F77 version 2.7.2.2.f.3 (Linux/Alpha) compiled @dots{} +GNU Fortran Front End version 0.5.21 compiled: @dots{} + as -nocpp -o /tmp/cca180481.o /tmp/cca18048.s + ld -G 8 -O1 -o /tmp/gfa18047 /usr/lib/crt0.o -L. @dots{} +__G77_LIBF77_VERSION__: 0.5.21 +@@(#)LIBF77 VERSION 19970404 +__G77_LIBI77_VERSION__: 0.5.21 +@@(#) LIBI77 VERSION pjw,dmg-mods 19970527 +__G77_LIBU77_VERSION__: 0.5.21 +@@(#) LIBU77 VERSION 19970609 +sh# @kbd{./xgcc -B./ -v -o /tmp/delete-me -xc /dev/null -xnone} +Reading specs from ./specs +gcc version 2.7.2.2.f.3 + ./cpp -lang-c -v -isystem ./include -undef @dots{} +GNU CPP version 2.7.2.2.f.3 (Linux/Alpha) +#include "..." search starts here: +#include <...> search starts here: + ./include + /usr/local/include + /usr/alpha-unknown-linux/include + /usr/lib/gcc-lib/alpha-unknown-linux/2.7.2.2.f.3/include + /usr/include +End of search list. + ./cc1 /tmp/cca18063.i -quiet -dumpbase null.c -version @dots{} +GNU C version 2.7.2.2.f.3 (Linux/Alpha) compiled @dots{} + as -nocpp -o /tmp/cca180631.o /tmp/cca18063.s + ld -G 8 -O1 -o /tmp/delete-me /usr/lib/crt0.o -L. @dots{} +/usr/lib/crt0.o: In function `__start': +crt0.S:110: undefined reference to `main' +/usr/lib/crt0.o(.lita+0x28): undefined reference to `main' +sh# +@end example + +(Note that long lines have been truncated, and @samp{@dots{}} +used to indicate such truncations.) + +The above two commands test whether @code{g77} and @code{gcc}, +respectively, are able to compile empty (null) source files, +whether invocation of the C preprocessor works, whether libraries +can be linked, and so on. + +If the output you get from either of the above two commands +is noticeably different, especially if it is shorter or longer +in ways that do not look consistent with the above sample +output, you probably should not install @code{gcc} and @code{g77} +until you have investigated further. + +For example, you could try compiling actual applications and +seeing how that works. +(You might want to do that anyway, even if the above tests +work.) + +To compile using the not-yet-installed versions of @code{gcc} +and @code{g77}, use the following commands to invoke them. + +To invoke @code{g77}, type: + +@example +/usr/src/gcc/g77 --driver=/usr/src/gcc/xgcc -B/usr/src/gcc/ @dots{} +@end example + +To invoke @code{gcc}, type: + +@example +/usr/src/gcc/xgcc -B/usr/src/gcc/ @dots{} +@end example + +@node Installation of Binaries +@subsection Installation of Binaries +@cindex installation of binaries +@cindex @code{g77}, installation of +@cindex @code{gcc}, installation of + +After configuring, building, and testing @code{g77} and @code{gcc}, +when you are ready to install them on your system, type: + +@example +make -k CC=gcc LANGUAGES=f77 install +@end example + +As described in @ref{Installation,,Installing GNU CC, +gcc,Using and Porting GNU CC}, the values for +the @samp{CC} and @samp{LANGUAGES} macros should +be the same as those you supplied for the build +itself. + +So, the details of the above command might vary +if you used a bootstrap build (where you might be +able to omit both definitions, or might have to +supply the same definitions you used when building +the final stage) or if you deviated from the +instructions for a straight build. + +If the above command does not install @file{libf2c.a} +as expected, try this: + +@example +make -k @dots{} install install-libf77 install-f2c-all +@end example + +We don't know why some non-GNU versions of @code{make} sometimes +require this alternate command, but they do. +(Remember to supply the appropriate definitions for @samp{CC} and +@samp{LANGUAGES} where you see @samp{@dots{}} in the above command.) + +Note that using the @samp{-k} option tells @code{make} to +continue after some installation problems, like not having +@code{makeinfo} installed on your system. +It might not be necessary for your system. + +@node Updating Documentation +@subsection Updating Your Info Directory +@cindex updating info directory +@cindex info, updating directory +@cindex directory, updating info +@pindex /usr/info/dir +@pindex g77.info +@cindex texinfo +@cindex documentation + +As part of installing @code{g77}, you should make sure users +of @code{info} can easily access this manual on-line. +Do this by making sure a line such as the following exists +in @file{/usr/info/dir}, or in whatever file is the top-level +file in the @code{info} directory on your system (perhaps +@file{/usr/local/info/dir}: + +@example +* g77: (g77). The GNU Fortran programming language. +@end example + +If the menu in @file{dir} is organized into sections, @code{g77} +probably belongs in a section with a name such as one of +the following: + +@itemize @bullet +@item +Fortran Programming + +@item +Writing Programs + +@item +Programming Languages + +@item +Languages Other Than C + +@item +Scientific/Engineering Tools + +@item +GNU Compilers +@end itemize + +@node Missing bison? +@subsection Missing @code{bison}? +@cindex @code{bison} +@cindex missing @code{bison} + +If you cannot install @code{bison}, make sure you have started +with a @emph{fresh} distribution of @code{gcc}, do @emph{not} +do @samp{make maintainer-clean} (in other versions of @code{gcc}, +this was called @samp{make realclean}), and, to ensure that +@code{bison} is not invoked by @code{make} during the build, +type these commands: + +@example +sh# @kbd{cd gcc} +sh# @kbd{touch bi-parser.c bi-parser.h c-parse.c c-parse.h cexp.c} +sh# @kbd{touch cp/parse.c cp/parse.h objc-parse.c} +sh# +@end example + +These commands update the date-time-modified information for +all the files produced by the various invocations of @code{bison} +in the current versions of @code{gcc}, so that @code{make} no +longer believes it needs to update them. +All of these files should already exist in a @code{gcc} +distribution, but the application of patches to upgrade +to a newer version can leave the modification information +set such that the @code{bison} input files look more ``recent'' +than the corresponding output files. + +@emph{Note:} New versions of @code{gcc} might change the set of +files it generates by invoking @code{bison}---if you cannot figure +out for yourself how to handle such a situation, try an +older version of @code{gcc} until you find someone who can +(or until you obtain and install @code{bison}). + +@node Missing makeinfo? +@subsection Missing @code{makeinfo}? +@cindex @code{makeinfo} +@cindex missing @code{makeinfo} + +If you cannot install @code{makeinfo}, either use the @code{-k} option when +invoking make to specify any of the @samp{install} or related targets, +or specify @samp{MAKEINFO=echo} on the @code{make} command line. + +If you fail to do one of these things, some files, like @file{libf2c.a}, +might not be installed, because the failed attempt by @code{make} to +invoke @code{makeinfo} causes it to cancel any further processing. + +@node Distributing Binaries +@section Distributing Binaries +@cindex binaries, distributing +@cindex code, distributing + +If you are building @code{g77} for distribution to others in binary form, +first make sure you are aware of your legal responsibilities (read +the file @file{gcc/COPYING} thoroughly). + +Then, consider your target audience and decide where @code{g77} should +be installed. + +For systems like GNU/Linux that have no native Fortran compiler (or +where @code{g77} could be considered the native compiler for Fortran and +@code{gcc} for C, etc.), you should definitely configure +@code{g77} for installation +in @file{/usr/bin} instead of @file{/usr/local/bin}. +Specify the +@samp{--prefix=/usr} option when running @file{./configure}. +You might +also want to set up the distribution so the @code{f77} command is a +link to @code{g77}---just make an empty file named @file{f77-install-ok} in +the source or build directory (the one in which the @file{f} directory +resides, not the @file{f} directory itself) when you specify one of the +@file{install} or @file{uninstall} targets in a @code{make} command. + +For a system that might already have @code{f2c} installed, you definitely +will want to make another empty file (in the same directory) named +either @file{f2c-exists-ok} or @file{f2c-install-ok}. +Use the former if you +don't want your distribution to overwrite @code{f2c}-related files in existing +systems; use the latter if you want to improve the likelihood that +users will be able to use both @code{f2c} and @code{g77} to compile code for a +single program without encountering link-time or run-time +incompatibilities. + +(Make sure you clearly document, in the ``advertising'' for +your distribution, how installation of your distribution will +affect existing installations of @code{gcc}, @code{f2c}, +@code{f77}, @file{libf2c.a}, and so on. +Similarly, you should clearly document any requirements +you assume are met by users of your distribution.) + +For other systems with native @code{f77} (and @code{cc}) compilers, +configure @code{g77} as you (or most of your audience) would +configure @code{gcc} for their installations. +Typically this is for installation in +@file{/usr/local}, and would not include a copy of +@code{g77} named @code{f77}, so +users could still use the native @code{f77}. + +In any case, for @code{g77} to work properly, you @strong{must} ensure +that the binaries you distribute include: + +@table @file +@item bin/g77 +This is the command most users use to compile Fortran. + +@item bin/gcc +This is the command all users use to compile Fortran, either +directly or indirectly via the @code{g77} command. +The @file{bin/gcc} executable file must have been built +from a @code{gcc} source tree into which a @code{g77} source +tree was merged and configured, or it will not know how +to compile Fortran programs. + +@item bin/f77 +In installations with no non-GNU native Fortran +compiler, this is the same as @file{bin/g77}. +Otherwise, it should be omitted from the distribution, +so the one on already on a particular system does +not get overwritten. + +@item info/g77.info* +This is the documentation for @code{g77}. +If it is not included, users will have trouble understanding +diagnostics messages and other such things, and will send +you a lot of email asking questions. + +Please edit this documentation (by editing @file{gcc/f/*.texi} +and doing @samp{make doc} from the @file{/usr/src/gcc} directory) +to reflect any changes you've made to @code{g77}, or at +least to encourage users of your binary distribution to +report bugs to you first. + +Also, whether you distribute binaries or install @code{g77} +on your own system, it might be helpful for everyone to +add a line listing this manual by name and topic to the +top-level @code{info} node in @file{/usr/info/dir}. +That way, users can find @code{g77} documentation more +easily. +@xref{Updating Documentation,,Updating Your Info Directory}. + +@item man/man1/g77.1 +This is the short man page for @code{g77}. +It is out of date, but you might as well include it +for people who really like man pages. + +@item man/man1/f77.1 +In installations where @code{f77} is the same as @code{g77}, +this is the same as @file{man/man1/g77.1}. +Otherwise, it should be omitted from the distribution, +so the one already on a particular system does not +get overwritten. + +@item lib/gcc-lib/@dots{}/f771 +This is the actual Fortran compiler. + +@item lib/gcc-lib/@dots{}/libf2c.a +This is the run-time library for @code{g77}-compiled programs. +@end table + +Whether you want to include the slightly updated (and possibly +improved) versions of @code{cc1}, @code{cc1plus}, and whatever other +binaries get rebuilt with the changes the GNU Fortran distribution +makes to the GNU back end, is up to you. +These changes are +highly unlikely to break any compilers, and it is possible +they'll fix back-end bugs that can be demonstrated using front +ends other than GNU Fortran's. + +Please assure users that unless +they have a specific need for their existing, +older versions of @code{gcc} command, +they are unlikely to experience any problems by overwriting +it with your version---though they could certainly protect +themselves by making backup copies first! +Otherwise, users might try and install your binaries +in a ``safe'' place, find they cannot compile Fortran +programs with your distribution (because, perhaps, they're +picking up their old version of the @code{gcc} command, +which does not recognize Fortran programs), and assume +that your binaries (or, more generally, GNU Fortran +distributions in general) are broken, at least for their +system. + +Finally, @strong{please} ask for bug reports to go to you first, at least +until you're sure your distribution is widely used and has been +well tested. +This especially goes for those of you making any +changes to the @code{g77} sources to port @code{g77}, e.g. to OS/2. +@email{fortran@@gnu.ai.mit.edu} has received a fair number of bug +reports that turned out to be problems with other peoples' ports +and distributions, about which nothing could be done for the +user. +Once you are quite certain a bug report does not involve +your efforts, you can forward it to us. diff --git a/gcc/f/install0.texi b/gcc/f/install0.texi new file mode 100644 index 000000000000..cfb59bf02198 --- /dev/null +++ b/gcc/f/install0.texi @@ -0,0 +1,14 @@ +@setfilename INSTALL +@set INSTALLONLY + +@c The immediately following lines apply to the INSTALL file +@c which is generated using this file. +This file contains installation information for the GNU Fortran compiler. +Copyright (C) 1995, 1996 Free Software Foundation, Inc. +You may copy, distribute, and modify it freely as long as you preserve +this copyright notice and permission notice. + +@node Top,,, (dir) +@chapter Installing GNU Fortran +@include install.texi +@bye diff --git a/gcc/f/intdoc.c b/gcc/f/intdoc.c new file mode 100644 index 000000000000..ff9a6f9bb4f7 --- /dev/null +++ b/gcc/f/intdoc.c @@ -0,0 +1,1339 @@ +/* intdoc.c + Copyright (C) 1997 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. */ + +/* From f/proj.h, which uses #error -- not all C compilers + support that, and we want _this_ program to be compilable + by pretty much any C compiler. */ + +#include "assert.j" /* Use gcc's assert.h. */ +#include +#include +#include +#include +#define FFEINTRIN_DOC 1 +#include "intrin.h" + +typedef enum + { +#if !defined(false) || !defined(true) + false = 0, true = 1, +#endif +#if !defined(FALSE) || !defined(TRUE) + FALSE = 0, TRUE = 1, +#endif + Doggone_Trailing_Comma_Dont_Work = 1 + } bool; + +#define ARRAY_SIZE(a) (sizeof(a)/sizeof(a[0])) + +char *family_name (ffeintrinFamily family); +static void dumpif (ffeintrinFamily fam); +static void dumpendif (void); +static void dumpclearif (void); +static void dumpem (void); +static void dumpgen (int menu, char *name, char *name_uc, + ffeintrinGen gen); +static void dumpspec (int menu, char *name, char *name_uc, + ffeintrinSpec spec); +static void dumpimp (int menu, char *name, char *name_uc, size_t genno, ffeintrinFamily family, + ffeintrinImp imp, ffeintrinSpec spec); +static char *argument_info_ptr (ffeintrinImp imp, int argno); +static char *argument_info_string (ffeintrinImp imp, int argno); +static char *argument_name_ptr (ffeintrinImp imp, int argno); +static char *argument_name_string (ffeintrinImp imp, int argno); +#if 0 +static char *elaborate_if_complex (ffeintrinImp imp, int argno); +static char *elaborate_if_maybe_complex (ffeintrinImp imp, int argno); +static char *elaborate_if_real (ffeintrinImp imp, int argno); +#endif +static void print_type_string (char *c); + +int +main (int argc, char **argv __attribute__ ((unused))) +{ + if (argc != 1) + { + fprintf (stderr, "\ +Usage: intdoc > intdoc.texi + Collects and dumps documentation on g77 intrinsics + to the file named intdoc.texi.\n"); + exit (1); + } + + dumpem (); + return 0; +} + +struct _ffeintrin_name_ + { + char *name_uc; + char *name_lc; + char *name_ic; + ffeintrinGen generic; + ffeintrinSpec specific; + }; + +struct _ffeintrin_gen_ + { + char *name; /* Name as seen in program. */ + ffeintrinSpec specs[2]; + }; + +struct _ffeintrin_spec_ + { + char *name; /* Uppercase name as seen in source code, + lowercase if no source name, "none" if no + name at all (NONE case). */ + bool is_actualarg; /* Ok to pass as actual arg if -pedantic. */ + ffeintrinFamily family; + ffeintrinImp implementation; + }; + +struct _ffeintrin_imp_ + { + char *name; /* Name of implementation. */ +#if 0 /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + ffecomGfrt gfrt; /* gfrt index in library. */ +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + char *control; + }; + +static struct _ffeintrin_name_ names[] = { +#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) \ + { UPPER, LOWER, MIXED, FFEINTRIN_ ## GEN, FFEINTRIN_ ## SPEC }, +#define DEFGEN(CODE,NAME,SPEC1,SPEC2) +#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) +#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) +#include "intrin.def" +#undef DEFNAME +#undef DEFGEN +#undef DEFSPEC +#undef DEFIMP +}; + +static struct _ffeintrin_gen_ gens[] = { +#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) +#define DEFGEN(CODE,NAME,SPEC1,SPEC2) \ + { NAME, { SPEC1, SPEC2, }, }, +#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) +#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) +#include "intrin.def" +#undef DEFNAME +#undef DEFGEN +#undef DEFSPEC +#undef DEFIMP +}; + +static struct _ffeintrin_imp_ imps[] = { +#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 }, +#elif 1 /* FFECOM_targetCURRENT == FFECOM_targetFFE */ +#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \ + { NAME, CONTROL }, +#else +#error +#endif +#include "intrin.def" +#undef DEFNAME +#undef DEFGEN +#undef DEFSPEC +#undef DEFIMP +}; + +static struct _ffeintrin_spec_ specs[] = { +#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) +#define DEFGEN(CODE,NAME,SPEC1,SPEC2) +#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) \ + { NAME, CALLABLE, FAMILY, IMP, }, +#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) +#include "intrin.def" +#undef DEFGEN +#undef DEFSPEC +#undef DEFIMP +}; + +struct cc_pair { ffeintrinImp imp; char *text; }; + +static char *descriptions[FFEINTRIN_imp] = { 0 }; +static struct cc_pair cc_descriptions[] = { +#define DEFDOC(IMP,SUMMARY,DESCRIPTION) { FFEINTRIN_imp ## IMP, DESCRIPTION }, +#include "intdoc.h" +#undef DEFDOC +}; + +static char *summaries[FFEINTRIN_imp] = { 0 }; +static struct cc_pair cc_summaries[] = { +#define DEFDOC(IMP,SUMMARY,DESCRIPTION) { FFEINTRIN_imp ## IMP, SUMMARY }, +#include "intdoc.h" +#undef DEFDOC +}; + +char * +family_name (ffeintrinFamily family) +{ + switch (family) + { + case FFEINTRIN_familyF77: + return "familyF77"; + + case FFEINTRIN_familyASC: + return "familyASC"; + + case FFEINTRIN_familyMIL: + return "familyMIL"; + + case FFEINTRIN_familyGNU: + return "familyGNU"; + + case FFEINTRIN_familyF90: + return "familyF90"; + + case FFEINTRIN_familyVXT: + return "familyVXT"; + + case FFEINTRIN_familyFVZ: + return "familyFVZ"; + + case FFEINTRIN_familyF2C: + return "familyF2C"; + + case FFEINTRIN_familyF2U: + return "familyF2U"; + + case FFEINTRIN_familyBADU77: + return "familyBADU77"; + + default: + assert ("bad family" == NULL); + return "??"; + } +} + +static int in_ifset = 0; +static ffeintrinFamily latest_family = FFEINTRIN_familyNONE; + +static void +dumpif (ffeintrinFamily fam) +{ + assert (fam != FFEINTRIN_familyNONE); + if ((in_ifset != 2) + || (fam != latest_family)) + { + if (in_ifset == 2) + printf ("@end ifset\n"); + latest_family = fam; + printf ("@ifset %s\n", family_name (fam)); + } + in_ifset = 1; +} + +static void +dumpendif () +{ + in_ifset = 2; +} + +static void +dumpclearif () +{ + if ((in_ifset == 2) + || (latest_family != FFEINTRIN_familyNONE)) + printf ("@end ifset\n"); + latest_family = FFEINTRIN_familyNONE; + in_ifset = 0; +} + +static void +dumpem () +{ + int i; + + for (i = 0; ((size_t) i) < ARRAY_SIZE (cc_descriptions); ++i) + { + assert (descriptions[cc_descriptions[i].imp] == NULL); + descriptions[cc_descriptions[i].imp] = cc_descriptions[i].text; + } + + for (i = 0; ((size_t) i) < ARRAY_SIZE (cc_summaries); ++i) + { + assert (summaries[cc_summaries[i].imp] == NULL); + summaries[cc_summaries[i].imp] = cc_summaries[i].text; + } + + printf ("@menu\n"); + for (i = 0; ((size_t) i) < ARRAY_SIZE (names); ++i) + { + if (names[i].generic != FFEINTRIN_genNONE) + dumpgen (1, names[i].name_ic, names[i].name_uc, + names[i].generic); + if (names[i].specific != FFEINTRIN_specNONE) + dumpspec (1, names[i].name_ic, names[i].name_uc, + names[i].specific); + } + dumpclearif (); + + printf ("@end menu\n\n"); + + for (i = 0; ((size_t) i) < ARRAY_SIZE (names); ++i) + { + if (names[i].generic != FFEINTRIN_genNONE) + dumpgen (0, names[i].name_ic, names[i].name_uc, + names[i].generic); + if (names[i].specific != FFEINTRIN_specNONE) + dumpspec (0, names[i].name_ic, names[i].name_uc, + names[i].specific); + } + dumpclearif (); +} + +static void +dumpgen (int menu, char *name, char *name_uc, ffeintrinGen gen) +{ + size_t i; + int total; + + if (!menu) + { + for (total = 0, i = 0; i < ARRAY_SIZE (gens[gen].specs); ++i) + { + if (gens[gen].specs[i] != FFEINTRIN_specNONE) + ++total; + } + } + + for (i = 0; i < ARRAY_SIZE (gens[gen].specs); ++i) + { + ffeintrinSpec spec; + size_t j; + + if ((spec = gens[gen].specs[i]) == FFEINTRIN_specNONE) + continue; + + dumpif (specs[spec].family); + dumpimp (menu, name, name_uc, i, specs[spec].family, specs[spec].implementation, + spec); + if (!menu && (total > 0)) + { + if (total == 1) + { + printf ("\ +For information on another intrinsic with the same name:\n"); + } + else + { + printf ("\ +For information on other intrinsics with the same name:\n"); + } + for (j = 0; j < ARRAY_SIZE (gens[gen].specs); ++j) + { + if (j == i) + continue; + if ((spec = gens[gen].specs[j]) == FFEINTRIN_specNONE) + continue; + printf ("@xref{%s Intrinsic (%s)}.\n", + name, specs[spec].name); + } + printf ("\n"); + } + dumpendif (); + } +} + +static void +dumpspec (int menu, char *name, char *name_uc, ffeintrinSpec spec) +{ + dumpif (specs[spec].family); + dumpimp (menu, name, name_uc, 0, specs[spec].family, specs[spec].implementation, + FFEINTRIN_specNONE); + dumpendif (); +} + +static void +dumpimp (int menu, char *name, char *name_uc, size_t genno, ffeintrinFamily family, ffeintrinImp imp, + ffeintrinSpec spec) +{ + char *c; + bool subr; + char *argc; + char *argi; + int colon; + int argno; + + assert ((imp != FFEINTRIN_impNONE) || !genno); + + if (menu) + { + printf ("* %s Intrinsic", + name); + if (spec != FFEINTRIN_specNONE) + printf (" (%s)", specs[spec].name); /* See XYZZY1 below */ + printf ("::"); +#define INDENT_SUMMARY 24 + if ((imp == FFEINTRIN_impNONE) + || (summaries[imp] != NULL)) + { + int spaces = INDENT_SUMMARY - 14 - strlen (name); + char *c; + + if (spec != FFEINTRIN_specNONE) + spaces -= (3 + strlen (specs[spec].name)); /* See XYZZY1 above */ + if (spaces < 1) + spaces = 1; + while (spaces--) + fputc (' ', stdout); + + if (imp == FFEINTRIN_impNONE) + { + printf ("(Reserved for future use.)\n"); + return; + } + + for (c = summaries[imp]; c[0] != '\0'; ++c) + { + if ((c[0] == '@') + && (c[1] >= '0') + && (c[1] <= '9')) + { + int argno = c[1] - '0'; + + c += 2; + while ((c[0] >= '0') + && (c[0] <= '9')) + { + argno = 10 * argno + (c[0] - '0'); + ++c; + } + assert (c[0] == '@'); + if (argno == 0) + printf ("%s", name); + else if (argno == 99) + { /* Yeah, this is a major kludge. */ + printf ("\n"); + spaces = INDENT_SUMMARY + 1; + while (spaces--) + fputc (' ', stdout); + } + else + printf ("%s", argument_name_string (imp, argno - 1)); + } + else + fputc (c[0], stdout); + } + } + printf ("\n"); + return; + } + + printf ("@node %s Intrinsic", name); + if (spec != FFEINTRIN_specNONE) + printf (" (%s)", specs[spec].name); + printf ("\n@subsubsection %s Intrinsic", name); + if (spec != FFEINTRIN_specNONE) + printf (" (%s)", specs[spec].name); + printf ("\n@cindex %s intrinsic\n@cindex intrinsics, %s\n", + name, name); + + if (imp == FFEINTRIN_impNONE) + { + printf (" +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL %s} to use this name for an +external procedure. + +", + name); + return; + } + + c = imps[imp].control; + subr = (c[0] == '-'); + colon = (c[2] == ':') ? 2 : 3; + + printf (" +@noindent +@example +%s%s(", + (subr ? "CALL " : ""), name); + + fflush (stdout); + + for (argno = 0; ; ++argno) + { + argc = argument_name_ptr (imp, argno); + if (argc == NULL) + break; + if (argno > 0) + printf (", "); + printf ("@var{%s}", argc); + argi = argument_info_string (imp, argno); + if ((argi[0] == '*') + || (argi[0] == 'n') + || (argi[0] == '+') + || (argi[0] == 'p')) + printf ("-1, @var{%s}-2, @dots{}, @var{%s}-n", + argc, argc); + } + + printf (") +@end example\n +"); + + if (!subr) + { + int other_arg; + char *arg_string; + char *arg_info; + + if ((c[colon + 1] >= '0') + && (c[colon + 1] <= '9')) + { + other_arg = c[colon + 1] - '0'; + arg_string = argument_name_string (imp, other_arg); + arg_info = argument_info_string (imp, other_arg); + } + else + { + other_arg = -1; + arg_string = NULL; + arg_info = NULL; + } + + printf ("\ +@noindent +%s: ", name); + print_type_string (c); + printf (" function"); + + if ((c[0] == 'R') + && (c[1] == 'C')) + { + assert (other_arg >= 0); + + if ((arg_info[0] == '?') || (arg_info[0] == '!') || (arg_info[0] == '+') + || (arg_info[0] == '*') || (arg_info[0] == 'n') || (arg_info[0] == 'p')) + ++arg_info; + if ((arg_info[0] == 'F') || (arg_info[0] == 'N')) + printf (". +The exact type is @samp{REAL(KIND=1)} when argument @var{%s} is +any type other than @code{COMPLEX}, or when it is @code{COMPLEX(KIND=1)}. +When @var{%s} is any @code{COMPLEX} type other than @code{COMPLEX(KIND=1)}, +this intrinsic is valid only when used as the argument to +@code{REAL()}, as explained below.\n\n", + arg_string, + arg_string); + else + printf (". +This intrinsic is valid when argument @var{%s} is +@code{COMPLEX(KIND=1)}. +When @var{%s} is any other @code{COMPLEX} type, +this intrinsic is valid only when used as the argument to +@code{REAL()}, as explained below.\n\n", + arg_string, + arg_string); + } +#if 0 + else if ((c[0] == 'I') + && (c[1] == 'p')) + printf (", the exact type being wide enough to hold a pointer +on the target system (typically @code{INTEGER(KIND=1)} or @code{INTEGER(KIND=4)}).\n\n"); +#endif + else if ((c[1] == '=') + && (c[colon + 1] >= '0') + && (c[colon + 1] <= '9')) + { + assert (other_arg >= 0); + + if ((arg_info[0] == '?') || (arg_info[0] == '!') || (arg_info[0] == '+') + || (arg_info[0] == '*') || (arg_info[0] == 'n') || (arg_info[0] == 'p')) + ++arg_info; + + if (((c[0] == arg_info[0]) + && ((c[0] == 'A') || (c[0] == 'C') || (c[0] == 'I') + || (c[0] == 'L') || (c[0] == 'R'))) + || ((c[0] == 'R') + && (arg_info[0] == 'C')) + || ((c[0] == 'C') + && (arg_info[0] == 'R'))) + printf (", the @samp{KIND=} value of the type being that of argument @var{%s}.\n\n", + arg_string); + else if ((c[0] == 'S') + && ((arg_info[0] == 'C') + || (arg_info[0] == 'F') + || (arg_info[0] == 'N'))) + printf (". +The exact type depends on that of argument @var{%s}---if @var{%s} is +@code{COMPLEX}, this function's type is @code{REAL} +with the same @samp{KIND=} value as the type of @var{%s}. +Otherwise, this function's type is the same as that of @var{%s}.\n\n", + arg_string, arg_string, arg_string, arg_string); + else + printf (", the exact type being that of argument @var{%s}.\n\n", + arg_string); + } + else if ((c[1] == '=') + && (c[colon + 1] == '*')) + printf (", the exact type being the result of cross-promoting the +types of all the arguments.\n\n"); + else if (c[1] == '=') + assert ("?0:?:" == NULL); + else + printf (".\n\n"); + } + + for (argno = 0, argc = &c[colon + 3]; *argc != '\0'; ++argno) + { + char optionality = '\0'; + char extra = '\0'; + char basic; + char kind; + int length; + int elements; + + printf ("\ +@noindent +@var{"); + for (; ; ++argc) + { + if (argc[0] == '=') + break; + printf ("%c", *argc); + } + printf ("}: "); + + ++argc; + if ((*argc == '?') + || (*argc == '!') + || (*argc == '*') + || (*argc == '+') + || (*argc == 'n') + || (*argc == 'p')) + optionality = *(argc++); + basic = *(argc++); + kind = *(argc++); + if (*argc == '[') + { + length = *++argc - '0'; + if (*++argc != ']') + length = 10 * length + (*(argc++) - '0'); + ++argc; + } + else + length = -1; + if (*argc == '(') + { + elements = *++argc - '0'; + if (*++argc != ')') + elements = 10 * elements + (*(argc++) - '0'); + ++argc; + } + else if (*argc == '&') + { + elements = -1; + ++argc; + } + else + elements = 0; + if ((*argc == '&') + || (*argc == 'i') + || (*argc == 'w') + || (*argc == 'x')) + extra = *(argc++); + if (*argc == ',') + ++argc; + + switch (basic) + { + case '-': + switch (kind) + { + case '*': + printf ("Any type"); + break; + + default: + assert ("kind arg" == NULL); + break; + } + break; + + case 'A': + assert ((kind == '1') || (kind == '*')); + printf ("@code{CHARACTER"); + if (length != -1) + printf ("*%d", length); + printf ("}"); + break; + + case 'C': + switch (kind) + { + case '*': + printf ("@code{COMPLEX}"); + break; + + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + printf ("@code{COMPLEX(KIND=%d)}", (kind - '0')); + break; + + case 'A': + printf ("Same @samp{KIND=} value as for @var{%s}", + argument_name_string (imp, 0)); + break; + + default: + assert ("Ca" == NULL); + break; + } + break; + + case 'I': + switch (kind) + { + case '*': + printf ("@code{INTEGER}"); + break; + + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + printf ("@code{INTEGER(KIND=%d)}", (kind - '0')); + break; + + case 'A': + printf ("@code{INTEGER} with same @samp{KIND=} value as for @var{%s}", + argument_name_string (imp, 0)); + break; + + case 'p': + printf ("@code{INTEGER} wide enough to hold a pointer"); + break; + + default: + assert ("Ia" == NULL); + break; + } + break; + + case 'L': + switch (kind) + { + case '*': + printf ("@code{LOGICAL}"); + break; + + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + printf ("@code{LOGICAL(KIND=%d)}", (kind - '0')); + break; + + case 'A': + printf ("@code{LOGICAL} with same @samp{KIND=} value as for @var{%s}", + argument_name_string (imp, 0)); + break; + + default: + assert ("La" == NULL); + break; + } + break; + + case 'R': + switch (kind) + { + case '*': + printf ("@code{REAL}"); + break; + + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + printf ("@code{REAL(KIND=%d)}", (kind - '0')); + break; + + case 'A': + printf ("@code{REAL} with same @samp{KIND=} value as for @var{%s}", + argument_name_string (imp, 0)); + break; + + default: + assert ("Ra" == NULL); + break; + } + break; + + case 'B': + switch (kind) + { + case '*': + printf ("@code{INTEGER} or @code{LOGICAL}"); + break; + + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + printf ("@code{INTEGER(KIND=%d)} or @code{LOGICAL(KIND=%d)}", + (kind - '0'), (kind - '0')); + break; + + case 'A': + printf ("Same type and @samp{KIND=} value as for @var{%s}", + argument_name_string (imp, 0)); + break; + + default: + assert ("Ba" == NULL); + break; + } + break; + + case 'F': + switch (kind) + { + case '*': + printf ("@code{REAL} or @code{COMPLEX}"); + break; + + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + printf ("@code{REAL(KIND=%d)} or @code{COMPLEX(KIND=%d)}", + (kind - '0'), (kind - '0')); + break; + + case 'A': + printf ("Same type as @var{%s}", + argument_name_string (imp, 0)); + break; + + default: + assert ("Fa" == NULL); + break; + } + break; + + case 'N': + switch (kind) + { + case '*': + printf ("@code{INTEGER}, @code{REAL}, or @code{COMPLEX}"); + break; + + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + printf ("@code{INTEGER(KIND=%d)}, @code{REAL(KIND=%d)}, or @code{COMPLEX(KIND=%d)}", + (kind - '0'), (kind - '0'), (kind - '0')); + break; + + default: + assert ("N1" == NULL); + break; + } + break; + + case 'S': + switch (kind) + { + case '*': + printf ("@code{INTEGER} or @code{REAL}"); + break; + + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + printf ("@code{INTEGER(KIND=%d)} or @code{REAL(KIND=%d)}", + (kind - '0'), (kind - '0')); + break; + + case 'A': + printf ("@code{INTEGER} or @code{REAL} with same @samp{KIND=} value as for @var{%s}", + argument_name_string (imp, 0)); + break; + + default: + assert ("Sa" == NULL); + break; + } + break; + + case 'g': + printf ("@samp{*@var{label}}, where @var{label} is the label +of an executable statement"); + break; + + case 's': + printf ("Signal handler (@code{INTEGER FUNCTION} or @code{SUBROUTINE}) +or dummy/global @code{INTEGER(KIND=1)} scalar"); + break; + + default: + assert ("arg type?" == NULL); + break; + } + + switch (optionality) + { + case '\0': + break; + + case '!': + printf ("; OPTIONAL (must be omitted if @var{%s} is @code{COMPLEX})", + argument_name_string (imp, argno-1)); + break; + + case '?': + printf ("; OPTIONAL"); + break; + + case '*': + printf ("; OPTIONAL"); + break; + + case 'n': + case '+': + break; + + case 'p': + printf ("; at least two such arguments must be provided"); + break; + + default: + assert ("optionality!" == NULL); + break; + } + + switch (elements) + { + case -1: + break; + + case 0: + if ((basic != 'g') + && (basic != 's')) + printf ("; scalar"); + break; + + default: + assert (extra != '\0'); + printf ("; DIMENSION(%d)", elements); + break; + } + + switch (extra) + { + case '\0': + if ((basic != 'g') + && (basic != 's')) + printf ("; INTENT(IN)"); + break; + + case 'i': + break; + + case '&': + printf ("; cannot be a constant or expression"); + break; + + case 'w': + printf ("; INTENT(OUT)"); + break; + + case 'x': + printf ("; INTENT(INOUT)"); + break; + } + + printf (".\n\n"); + } + + printf ("\ +@noindent +Intrinsic groups: "); + switch (family) + { + case FFEINTRIN_familyF77: + printf ("(standard FORTRAN 77)."); + break; + + case FFEINTRIN_familyGNU: + printf ("@code{gnu}."); + break; + + case FFEINTRIN_familyASC: + printf ("@code{f2c}, @code{f90}."); + break; + + case FFEINTRIN_familyMIL: + printf ("@code{mil}, @code{f90}, @code{vxt}."); + break; + + case FFEINTRIN_familyF90: + printf ("@code{f90}."); + break; + + case FFEINTRIN_familyVXT: + printf ("@code{vxt}."); + break; + + case FFEINTRIN_familyFVZ: + printf ("@code{f2c}, @code{vxt}."); + break; + + case FFEINTRIN_familyF2C: + printf ("@code{f2c}."); + break; + + case FFEINTRIN_familyF2U: + printf ("@code{unix}."); + break; + + case FFEINTRIN_familyBADU77: + printf ("@code{badu77}."); + break; + + default: + assert ("bad family" == NULL); + printf ("@code{???}."); + break; + } + printf ("\n\n"); + + if (descriptions[imp] != NULL) + { + char *c = descriptions[imp]; + + printf ("\ +@noindent +Description: +\n"); + + while (c[0] != '\0') + { + if ((c[0] == '@') + && (c[1] >= '0') + && (c[1] <= '9')) + { + int argno = c[1] - '0'; + + c += 2; + while ((c[0] >= '0') + && (c[0] <= '9')) + { + argno = 10 * argno + (c[0] - '0'); + ++c; + } + assert (c[0] == '@'); + if (argno == 0) + printf ("%s", name_uc); + else + printf ("%s", argument_name_string (imp, argno - 1)); + } + else + fputc (c[0], stdout); + ++c; + } + + printf ("\n"); + } +} + +static char * +argument_info_ptr (ffeintrinImp imp, int argno) +{ + char *c = imps[imp].control; + static char arginfos[8][32]; + static int argx = 0; + int i; + + if (c[2] == ':') + c += 5; + else + c += 6; + + while (argno--) + { + while ((c[0] != ',') && (c[0] != '\0')) + ++c; + if (c[0] != ',') + break; + ++c; + } + + if (c[0] == '\0') + return NULL; + + for (; (c[0] != '=') && (c[0] != '\0'); ++c) + ; + + assert (c[0] == '='); + + for (i = 0, ++c; (c[0] != ',') && (c[0] != '\0'); ++c, ++i) + arginfos[argx][i] = c[0]; + + arginfos[argx][i] = '\0'; + + c = &arginfos[argx][0]; + ++argx; + if (((size_t) argx) >= ARRAY_SIZE (arginfos)) + argx = 0; + + return c; +} + +static char * +argument_info_string (ffeintrinImp imp, int argno) +{ + char *p; + + p = argument_info_ptr (imp, argno); + assert (p != NULL); + return p; +} + +static char * +argument_name_ptr (ffeintrinImp imp, int argno) +{ + char *c = imps[imp].control; + static char argnames[8][32]; + static int argx = 0; + int i; + + if (c[2] == ':') + c += 5; + else + c += 6; + + while (argno--) + { + while ((c[0] != ',') && (c[0] != '\0')) + ++c; + if (c[0] != ',') + break; + ++c; + } + + if (c[0] == '\0') + return NULL; + + for (i = 0; (c[0] != '=') && (c[0] != '\0'); ++c, ++i) + argnames[argx][i] = c[0]; + + assert (c[0] == '='); + argnames[argx][i] = '\0'; + + c = &argnames[argx][0]; + ++argx; + if (((size_t) argx) >= ARRAY_SIZE (argnames)) + argx = 0; + + return c; +} + +static char * +argument_name_string (ffeintrinImp imp, int argno) +{ + char *p; + + p = argument_name_ptr (imp, argno); + assert (p != NULL); + return p; +} + +static void +print_type_string (char *c) +{ + char basic = c[0]; + char kind = c[1]; + + switch (basic) + { + case 'A': + assert ((kind == '1') || (kind == '=')); + if (c[2] == ':') + printf ("@code{CHARACTER*1}"); + else + { + assert (c[2] == '*'); + printf ("@code{CHARACTER*(*)}"); + } + break; + + case 'C': + switch (kind) + { + case '=': + printf ("@code{COMPLEX}"); + break; + + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + printf ("@code{COMPLEX(KIND=%d)}", (kind - '0')); + break; + + default: + assert ("Ca" == NULL); + break; + } + break; + + case 'I': + switch (kind) + { + case '=': + printf ("@code{INTEGER}"); + break; + + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + printf ("@code{INTEGER(KIND=%d)}", (kind - '0')); + break; + + case 'p': + printf ("@code{INTEGER(KIND=0)}"); + break; + + default: + assert ("Ia" == NULL); + break; + } + break; + + case 'L': + switch (kind) + { + case '=': + printf ("@code{LOGICAL}"); + break; + + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + printf ("@code{LOGICAL(KIND=%d)}", (kind - '0')); + break; + + default: + assert ("La" == NULL); + break; + } + break; + + case 'R': + switch (kind) + { + case '=': + printf ("@code{REAL}"); + break; + + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + printf ("@code{REAL(KIND=%d)}", (kind - '0')); + break; + + case 'C': + printf ("@code{REAL}"); + break; + + default: + assert ("Ra" == NULL); + break; + } + break; + + case 'B': + switch (kind) + { + case '=': + printf ("@code{INTEGER} or @code{LOGICAL}"); + break; + + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + printf ("@code{INTEGER(KIND=%d)} or @code{LOGICAL(KIND=%d)}", + (kind - '0'), (kind - '0')); + break; + + default: + assert ("Ba" == NULL); + break; + } + break; + + case 'F': + switch (kind) + { + case '=': + printf ("@code{REAL} or @code{COMPLEX}"); + break; + + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + printf ("@code{REAL(KIND=%d)} or @code{COMPLEX(KIND=%d)}", + (kind - '0'), (kind - '0')); + break; + + default: + assert ("Fa" == NULL); + break; + } + break; + + case 'N': + switch (kind) + { + case '=': + printf ("@code{INTEGER}, @code{REAL}, or @code{COMPLEX}"); + break; + + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + printf ("@code{INTEGER(KIND=%d)}, @code{REAL(KIND=%d)}, or @code{COMPLEX(KIND=%d)}", + (kind - '0'), (kind - '0'), (kind - '0')); + break; + + default: + assert ("N1" == NULL); + break; + } + break; + + case 'S': + switch (kind) + { + case '=': + printf ("@code{INTEGER} or @code{REAL}"); + break; + + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + printf ("@code{INTEGER(KIND=%d)} or @code{REAL(KIND=%d)}", + (kind - '0'), (kind - '0')); + break; + + default: + assert ("Sa" == NULL); + break; + } + break; + + default: + assert ("arg type?" == NULL); + break; + } +} diff --git a/gcc/f/intdoc.h b/gcc/f/intdoc.h new file mode 100644 index 000000000000..58b4007f7d5e --- /dev/null +++ b/gcc/f/intdoc.h @@ -0,0 +1,2370 @@ +/* Copyright (C) 1997 Free Software Foundation, Inc. + * This is part of the G77 manual. + * For copying conditions, see the file g77.texi. */ + +/* This is the file containing the verbage for the + intrinsics. It consists of a data base built up + via DEFDOC macros of the form: + + DEFDOC (IMP, SUMMARY, DESCRIPTION) + + IMP is the implementation keyword used in the intrin module. + SUMMARY is the short summary to go in the "* Menu:" section + of the Info document. DESCRIPTION is the longer description + to go in the documentation itself. + + Note that IMP is leveraged across multiple intrinsic names. + + To make for more accurate and consistent documentation, + the translation made by intdoc.c of the text in SUMMARY + and DESCRIPTION includes the special sequence + + @ARGNO@ + + where ARGNO is a series of digits forming a number that + is substituted by intdoc.c as follows: + + 0 The initial-caps form of the intrinsic name (e.g. Float). + 1-98 The initial-caps form of the ARGNO'th argument. + 99 (SUMMARY only) a newline plus the appropriate # of spaces. + + Hope this info is enough to encourage people to feel free to + add documentation to this file! + +*/ + +/* ~~~~~ to do: + ALARM +*/ + +#define ARCHAIC(upper,mixed) \ + "Archaic form of @code{" #upper "()} that is specific\n\ +to one type for @var{@1@}.\n\ +@xref{" #mixed " Intrinsic}.\n" + +#define ARCHAIC_2nd(upper,mixed) \ + "Archaic form of @code{" #upper "()} that is specific\n\ +to one type for @var{@2@}.\n\ +@xref{" #mixed " Intrinsic}.\n" + +#define ARCHAIC_2(upper,mixed) \ + "Archaic form of @code{" #upper "()} that is specific\n\ +to one type for @var{@1@} and @var{@2@}.\n\ +@xref{" #mixed " Intrinsic}.\n" + +DEFDOC (ABS, "Absolute value.", "\ +Returns the absolute value of @var{@1@}. + +If @var{@1@} is type @code{COMPLEX}, the absolute +value is computed as: + +@example +SQRT(REALPART(@var{@1@})**2, IMAGPART(@var{@1@})**2) +@end example + +@noindent +Otherwise, it is computed by negating the @var{@1@} if +it is negative, or returning @var{@1@}. + +@xref{Sign Intrinsic}, for how to explicitly +compute the positive or negative form of the absolute +value of an expression. +") + +DEFDOC (CABS, "Absolute value (archaic).", ARCHAIC (ABS, Abs)) + +DEFDOC (DABS, "Absolute value (archaic).", ARCHAIC (ABS, Abs)) + +DEFDOC (IABS, "Absolute value (archaic).", ARCHAIC (ABS, Abs)) + +DEFDOC (CDABS, "Absolute value (archaic).", ARCHAIC (ABS, Abs)) + +DEFDOC (ACHAR, "ASCII character from code.", "\ +Returns the ASCII character corresponding to the +code specified by @var{@1@}. + +@xref{IAChar Intrinsic}, for the inverse of this function. + +@xref{Char Intrinsic}, for the function corresponding +to the system's native character set. +") + +DEFDOC (IACHAR, "ASCII code for character.", "\ +Returns the code for the ASCII character in the +first character position of @var{@1@}. + +@xref{AChar Intrinsic}, for the inverse of this function. + +@xref{IChar Intrinsic}, for the function corresponding +to the system's native character set. +") + +DEFDOC (CHAR, "Character from code.", "\ +Returns the character corresponding to the +code specified by @var{@1@}, using the system's +native character set. + +Because the system's native character set is used, +the correspondence between character and their codes +is not necessarily the same between GNU Fortran +implementations. + +Note that no intrinsic exists to convert a numerical +value to a printable character string. +For example, there is no intrinsic that, given +an @code{INTEGER} or @code{REAL} argument with the +value @samp{154}, returns the @code{CHARACTER} +result @samp{'154'}. + +Instead, you can use internal-file I/O to do this kind +of conversion. +For example: + +@smallexample +INTEGER VALUE +CHARACTER*10 STRING +VALUE = 154 +WRITE (STRING, '(I10)'), VALUE +PRINT *, STRING +END +@end smallexample + +The above program, when run, prints: + +@smallexample + 154 +@end smallexample + +@xref{IChar Intrinsic}, for the inverse of the @code{@0@} function. + +@xref{AChar Intrinsic}, for the function corresponding +to the ASCII character set. +") + +DEFDOC (ICHAR, "Code for character.", "\ +Returns the code for the character in the +first character position of @var{@1@}. + +Because the system's native character set is used, +the correspondence between character and their codes +is not necessarily the same between GNU Fortran +implementations. + +Note that no intrinsic exists to convert a printable +character string to a numerical value. +For example, there is no intrinsic that, given +the @code{CHARACTER} value @samp{'154'}, returns an +@code{INTEGER} or @code{REAL} value with the value @samp{154}. + +Instead, you can use internal-file I/O to do this kind +of conversion. +For example: + +@smallexample +INTEGER VALUE +CHARACTER*10 STRING +STRING = '154' +READ (STRING, '(I10)'), VALUE +PRINT *, VALUE +END +@end smallexample + +The above program, when run, prints: + +@smallexample + 154 +@end smallexample + +@xref{Char Intrinsic}, for the inverse of the @code{@0@} function. + +@xref{IAChar Intrinsic}, for the function corresponding +to the ASCII character set. +") + +DEFDOC (ACOS, "Arc cosine.", "\ +Returns the arc-cosine (inverse cosine) of @var{@1@} +in radians. + +@xref{Cos Intrinsic}, for the inverse of this function. +") + +DEFDOC (DACOS, "Arc cosine (archaic).", ARCHAIC (ACOS, ACos)) + +DEFDOC (AIMAG, "Convert/extract imaginary part of complex.", "\ +Returns the (possibly converted) imaginary part of @var{@1@}. + +Use of @code{@0@()} with an argument of a type +other than @code{COMPLEX(KIND=1)} is restricted to the following case: + +@example +REAL(AIMAG(@1@)) +@end example + +@noindent +This expression converts the imaginary part of @1@ to +@code{REAL(KIND=1)}. + +@xref{REAL() and AIMAG() of Complex}, for more information. +") + +DEFDOC (DIMAG, "Convert/extract imaginary part of complex (archaic).", ARCHAIC (AIMAG, AImag)) + +DEFDOC (AINT, "Truncate to whole number.", "\ +Returns @var{@1@} with the fractional portion of its +magnitude truncated and its sign preserved. +(Also called ``truncation towards zero''.) + +@xref{ANInt Intrinsic}, for how to round to nearest +whole number. + +@xref{Int Intrinsic}, for how to truncate and then convert +number to @code{INTEGER}. +") + +DEFDOC (DINT, "Truncate to whole number (archaic).", ARCHAIC (AINT, AInt)) + +DEFDOC (INT, "Convert to @code{INTEGER} value truncated@99@to whole number.", "\ +Returns @var{@1@} with the fractional portion of its +magnitude truncated and its sign preserved, converted +to type @code{INTEGER(KIND=1)}. + +If @var{@1@} is type @code{COMPLEX}, its real part is +truncated and converted, and its imaginary part is disregarded. + +@xref{NInt Intrinsic}, for how to convert, rounded to nearest +whole number. + +@xref{AInt Intrinsic}, for how to truncate to whole number +without converting. +") + +DEFDOC (IDINT, "Convert to @code{INTEGER} value truncated@99@to whole number (archaic).", ARCHAIC (INT, Int)) + +DEFDOC (ANINT, "Round to nearest whole number.", "\ +Returns @var{@1@} with the fractional portion of its +magnitude eliminated by rounding to the nearest whole +number and with its sign preserved. + +A fractional portion exactly equal to +@samp{.5} is rounded to the whole number that +is larger in magnitude. +(Also called ``Fortran round''.) + +@xref{AInt Intrinsic}, for how to truncate to +whole number. + +@xref{NInt Intrinsic}, for how to round and then convert +number to @code{INTEGER}. +") + +DEFDOC (DNINT, "Round to nearest whole number (archaic).", ARCHAIC (ANINT, ANInt)) + +DEFDOC (NINT, "Convert to @code{INTEGER} value rounded@99@to nearest whole number.", "\ +Returns @var{@1@} with the fractional portion of its +magnitude eliminated by rounding to the nearest whole +number and with its sign preserved, converted +to type @code{INTEGER(KIND=1)}. + +If @var{@1@} is type @code{COMPLEX}, its real part is +rounded and converted. + +A fractional portion exactly equal to +@samp{.5} is rounded to the whole number that +is larger in magnitude. +(Also called ``Fortran round''.) + +@xref{Int Intrinsic}, for how to convert, truncate to +whole number. + +@xref{ANInt Intrinsic}, for how to round to nearest whole number +without converting. +") + +DEFDOC (IDNINT, "Convert to @code{INTEGER} value rounded@99@to nearest whole number (archaic).", ARCHAIC (NINT, NInt)) + +DEFDOC (LOG, "Natural logarithm.", "\ +Returns the natural logarithm of @var{@1@}, which must +be greater than zero or, if type @code{COMPLEX}, must not +be zero. + +@xref{Exp Intrinsic}, for the inverse of this function. + +@xref{Log10 Intrinsic}, for the base-10 logarithm function. +") + +DEFDOC (ALOG, "Natural logarithm (archaic).", ARCHAIC (LOG, Log)) + +DEFDOC (CLOG, "Natural logarithm (archaic).", ARCHAIC (LOG, Log)) + +DEFDOC (DLOG, "Natural logarithm (archaic).", ARCHAIC (LOG, Log)) + +DEFDOC (CDLOG, "Natural logarithm (archaic).", ARCHAIC (LOG, Log)) + +DEFDOC (LOG10, "Natural logarithm.", "\ +Returns the natural logarithm of @var{@1@}, which must +be greater than zero or, if type @code{COMPLEX}, must not +be zero. + +The inverse of this function is @samp{10. ** LOG10(@var{@1@})}. + +@xref{Log Intrinsic}, for the natural logarithm function. +") + +DEFDOC (ALOG10, "Natural logarithm (archaic).", ARCHAIC (LOG10, Log10)) + +DEFDOC (DLOG10, "Natural logarithm (archaic).", ARCHAIC (LOG10, Log10)) + +DEFDOC (MAX, "Maximum value.", "\ +Returns the argument with the largest value. + +@xref{Min Intrinsic}, for the opposite function. +") + +DEFDOC (AMAX0, "Maximum value (archaic).", "\ +Archaic form of @code{MAX()} that is specific +to one type for @var{@1@} and a different return type. +@xref{Max Intrinsic}. +") + +DEFDOC (AMAX1, "Maximum value (archaic).", ARCHAIC (MAX, Max)) + +DEFDOC (DMAX1, "Maximum value (archaic).", ARCHAIC (MAX, Max)) + +DEFDOC (MAX0, "Maximum value (archaic).", ARCHAIC (MAX, Max)) + +DEFDOC (MAX1, "Maximum value (archaic).", "\ +Archaic form of @code{MAX()} that is specific +to one type for @var{@1@} and a different return type. +@xref{Max Intrinsic}. +") + +DEFDOC (MIN, "Minimum value.", "\ +Returns the argument with the smallest value. + +@xref{Max Intrinsic}, for the opposite function. +") + +DEFDOC (AMIN0, "Minimum value (archaic).", "\ +Archaic form of @code{MIN()} that is specific +to one type for @var{@1@} and a different return type. +@xref{Min Intrinsic}. +") + +DEFDOC (AMIN1, "Minimum value (archaic).", ARCHAIC (MIN, Min)) + +DEFDOC (DMIN1, "Minimum value (archaic).", ARCHAIC (MIN, Min)) + +DEFDOC (MIN0, "Minimum value (archaic).", ARCHAIC (MIN, Min)) + +DEFDOC (MIN1, "Minimum value (archaic).", "\ +Archaic form of @code{MIN()} that is specific +to one type for @var{@1@} and a different return type. +@xref{Min Intrinsic}. +") + +DEFDOC (MOD, "Remainder.", "\ +Returns remainder calculated as: + +@smallexample +@var{@1@} - (INT(@var{@1@} / @var{@2@}) * @var{@2@}) +@end smallexample + +@var{@2@} must not be zero. +") + +DEFDOC (AMOD, "Remainder (archaic).", ARCHAIC (MOD, Mod)) + +DEFDOC (DMOD, "Remainder (archaic).", ARCHAIC (MOD, Mod)) + +DEFDOC (AND, "Boolean AND.", "\ +Returns value resulting from boolean AND of +pair of bits in each of @var{@1@} and @var{@2@}. +") + +DEFDOC (IAND, "Boolean AND.", "\ +Returns value resulting from boolean AND of +pair of bits in each of @var{@1@} and @var{@2@}. +") + +DEFDOC (OR, "Boolean OR.", "\ +Returns value resulting from boolean OR of +pair of bits in each of @var{@1@} and @var{@2@}. +") + +DEFDOC (IOR, "Boolean OR.", "\ +Returns value resulting from boolean OR of +pair of bits in each of @var{@1@} and @var{@2@}. +") + +DEFDOC (XOR, "Boolean XOR.", "\ +Returns value resulting from boolean exclusive-OR of +pair of bits in each of @var{@1@} and @var{@2@}. +") + +DEFDOC (IEOR, "Boolean XOR.", "\ +Returns value resulting from boolean exclusive-OR of +pair of bits in each of @var{@1@} and @var{@2@}. +") + +DEFDOC (NOT, "Boolean NOT.", "\ +Returns value resulting from boolean NOT of each bit +in @var{@1@}. +") + +DEFDOC (ASIN, "Arc sine.", "\ +Returns the arc-sine (inverse sine) of @var{@1@} +in radians. + +@xref{Sin Intrinsic}, for the inverse of this function. +") + +DEFDOC (DASIN, "Arc sine (archaic).", ARCHAIC (ASIN, ASin)) + +DEFDOC (ATAN, "Arc tangent.", "\ +Returns the arc-tangent (inverse tangent) of @var{@1@} +in radians. + +@xref{Tan Intrinsic}, for the inverse of this function. +") + +DEFDOC (DATAN, "Arc tangent (archaic).", ARCHAIC (ATAN, ATan)) + +DEFDOC (ATAN2, "Arc tangent.", "\ +Returns the arc-tangent (inverse tangent) of the complex +number (@var{@1@}, @var{@2@}) in radians. + +@xref{Tan Intrinsic}, for the inverse of this function. +") + +DEFDOC (DATAN2, "Arc tangent (archaic).", ARCHAIC_2 (ATAN2, ATan2)) + +DEFDOC (BIT_SIZE, "Number of bits in argument's type.", "\ +Returns the number of bits (integer precision plus sign bit) +represented by the type for @var{@1@}. + +@xref{BTest Intrinsic}, for how to test the value of a +bit in a variable or array. + +@xref{IBSet Intrinsic}, for how to set a bit in a variable to 1. + +@xref{IBClr Intrinsic}, for how to set a bit in a variable to 0. + +") + +DEFDOC (BTEST, "Test bit.", "\ +Returns @code{.TRUE.} if bit @var{@2@} in @var{@1@} is +1, @code{.FALSE.} otherwise. + +(Bit 0 is the low-order (rightmost) bit, adding the value +@ifinfo +2**0, +@end ifinfo +@iftex +@tex +$2^0$, +@end tex +@end iftex +or 1, +to the number if set to 1; +bit 1 is the next-higher-order bit, adding +@ifinfo +2**1, +@end ifinfo +@iftex +@tex +$2^1$, +@end tex +@end iftex +or 2; +bit 2 adds +@ifinfo +2**2, +@end ifinfo +@iftex +@tex +$2^2$, +@end tex +@end iftex +or 4; and so on.) + +@xref{Bit_Size Intrinsic}, for how to obtain the number of bits +in a type. +The leftmost bit of @var{@1@} is @samp{BIT_SIZE(@var{@1@}-1}. +") + +DEFDOC (CMPLX, "Construct @code{COMPLEX(KIND=1)} value.", "\ +If @var{@1@} is not type @code{COMPLEX}, +constructs a value of type @code{COMPLEX(KIND=1)} from the +real and imaginary values specified by @var{@1@} and +@var{@2@}, respectively. +If @var{@2@} is omitted, @samp{0.} is assumed. + +If @var{@1@} is type @code{COMPLEX}, +converts it to type @code{COMPLEX(KIND=1)}. + +@xref{Complex Intrinsic}, for information on easily constructing +a @code{COMPLEX} value of arbitrary precision from @code{REAL} +arguments. +") + +DEFDOC (DCMPLX, "Construct @code{COMPLEX(KIND=2)} value.", "\ +If @var{@1@} is not type @code{COMPLEX}, +constructs a value of type @code{COMPLEX(KIND=2)} from the +real and imaginary values specified by @var{@1@} and +@var{@2@}, respectively. +If @var{@2@} is omitted, @samp{0D0} is assumed. + +If @var{@1@} is type @code{COMPLEX}, +converts it to type @code{COMPLEX(KIND=2)}. + +Although this intrinsic is not standard Fortran, +it is a popular extension offered by many compilers +that support @code{DOUBLE COMPLEX}, since it offers +the easiest way to convert to @code{DOUBLE COMPLEX} +without using Fortran 90 features (such as the @samp{KIND=} +argument to the @code{CMPLX()} intrinsic). + +(@samp{CMPLX(0D0, 0D0)} returns a single-precision +@code{COMPLEX} result, as required by standard FORTRAN 77. +That's why so many compilers provide @code{DCMPLX()}, since +@samp{DCMPLX(0D0, 0D0)} returns a @code{DOUBLE COMPLEX} +result. +Still, @code{DCMPLX()} converts even @code{REAL*16} arguments +to their @code{REAL*8} equivalents in most dialects of +Fortran, so neither it nor @code{CMPLX()} allow easy +construction of arbitrary-precision values without +potentially forcing a conversion involving extending or +reducing precision. +GNU Fortran provides such an intrinsic, called @code{COMPLEX()}.) + +@xref{Complex Intrinsic}, for information on easily constructing +a @code{COMPLEX} value of arbitrary precision from @code{REAL} +arguments. +") + +DEFDOC (CONJG, "Complex conjugate.", "\ +Returns the complex conjugate: + +@example +COMPLEX(REALPART(@var{@1@}), -IMAGPART(@var{@1@})) +@end example +") + +DEFDOC (DCONJG, "Complex conjugate (archaic).", ARCHAIC (CONJG, ATan2)) + +DEFDOC (COS, "Cosine.", "\ +Returns the cosine of @var{@1@}, an angle measured +in radians. + +@xref{ACos Intrinsic}, for the inverse of this function. +") + +DEFDOC (CCOS, "Cosine (archaic).", ARCHAIC (COS, Cos)) + +DEFDOC (DCOS, "Cosine (archaic).", ARCHAIC (COS, Cos)) + +DEFDOC (CDCOS, "Cosine (archaic).", ARCHAIC (COS, Cos)) + +DEFDOC (COSH, "Hyperbolic cosine.", "\ +Returns the hyperbolic cosine of @var{@1@}. +") + +DEFDOC (DCOSH, "Hyperbolic cosine (archaic).", ARCHAIC (COSH, CosH)) + +DEFDOC (SQRT, "Square root.", "\ +Returns the square root of @var{@1@}, which must +not be negative. + +To calculate and represent the square root of a negative +number, complex arithmetic must be used. +For example, @samp{SQRT(COMPLEX(@var{@1@}))}. + +The inverse of this function is @samp{SQRT(@var{@1@}) * SQRT(@var{@1@})}. +") + +DEFDOC (CSQRT, "Square root (archaic).", ARCHAIC (SQRT, SqRt)) + +DEFDOC (DSQRT, "Square root (archaic).", ARCHAIC (SQRT, SqRt)) + +DEFDOC (CDSQRT, "Square root (archaic).", ARCHAIC (SQRT, SqRt)) + +DEFDOC (DBLE, "Convert to double precision.", "\ +Returns @var{@1@} converted to double precision +(@code{REAL(KIND=2)}). +If @var{@1@} is @code{COMPLEX}, the real part of +@var{@1@} is used for the conversion +and the imaginary part disregarded. + +@xref{Sngl Intrinsic}, for the function that converts +to single precision. + +@xref{Int Intrinsic}, for the function that converts +to @code{INTEGER}. + +@xref{Complex Intrinsic}, for the function that converts +to @code{COMPLEX}. +") + +DEFDOC (DIM, "Difference magnitude (non-negative subtract).", "\ +Returns @samp{@var{@1@}-@var{@2@}} if @var{@1@} is greater than +@var{@2@}; otherwise returns zero. +") + +DEFDOC (DDIM, "Difference magnitude (archaic).", ARCHAIC_2 (DIM, DiM)) +DEFDOC (IDIM, "Difference magnitude (archaic).", ARCHAIC_2 (IDIM, IDiM)) + +DEFDOC (DPROD, "Double-precision product.", "\ +Returns @samp{DBLE(@var{@1@})*DBLE(@var{@2@})}. +") + +DEFDOC (EXP, "Exponential.", "\ +Returns @samp{@var{e}**@var{@1@}}, where +@var{e} is approximately 2.7182818. + +@xref{Log Intrinsic}, for the inverse of this function. +") + +DEFDOC (CEXP, "Exponential (archaic).", ARCHAIC (EXP, Exp)) + +DEFDOC (DEXP, "Exponential (archaic).", ARCHAIC (EXP, Exp)) + +DEFDOC (CDEXP, "Exponential (archaic).", ARCHAIC (EXP, Exp)) + +DEFDOC (FLOAT, "Conversion (archaic).", ARCHAIC (REAL, Real)) +DEFDOC (DFLOAT, "Conversion (archaic).", ARCHAIC (REAL, Real)) + +DEFDOC (IFIX, "Conversion (archaic).", ARCHAIC (INT, Int)) + +DEFDOC (LONG, "Conversion to @code{INTEGER(KIND=1)} (archaic).", "\ +Archaic form of @code{INT()} that is specific +to one type for @var{@1@}. +@xref{Int Intrinsic}. + +The precise meaning of this intrinsic might change +in a future version of the GNU Fortran language, +as more is learned about how it is used. +") + +DEFDOC (SHORT, "Convert to @code{INTEGER(KIND=6)} value@99@truncated to whole number.", "\ +Returns @var{@1@} with the fractional portion of its +magnitude truncated and its sign preserved, converted +to type @code{INTEGER(KIND=6)}. + +If @var{@1@} is type @code{COMPLEX}, its real part +is truncated and converted, and its imaginary part is disgregarded. + +@xref{Int Intrinsic}. + +The precise meaning of this intrinsic might change +in a future version of the GNU Fortran language, +as more is learned about how it is used. +") + +DEFDOC (INT2, "Convert to @code{INTEGER(KIND=6)} value@99@truncated to whole number.", "\ +Returns @var{@1@} with the fractional portion of its +magnitude truncated and its sign preserved, converted +to type @code{INTEGER(KIND=6)}. + +If @var{@1@} is type @code{COMPLEX}, its real part +is truncated and converted, and its imaginary part is disgregarded. + +@xref{Int Intrinsic}. + +The precise meaning of this intrinsic might change +in a future version of the GNU Fortran language, +as more is learned about how it is used. +") + +DEFDOC (INT8, "Convert to @code{INTEGER(KIND=2)} value@99@truncated to whole number.", "\ +Returns @var{@1@} with the fractional portion of its +magnitude truncated and its sign preserved, converted +to type @code{INTEGER(KIND=2)}. + +If @var{@1@} is type @code{COMPLEX}, its real part +is truncated and converted, and its imaginary part is disgregarded. + +@xref{Int Intrinsic}. + +The precise meaning of this intrinsic might change +in a future version of the GNU Fortran language, +as more is learned about how it is used. +") + +DEFDOC (LEN, "Length of character entity.", "\ +Returns the length of @var{@1@}. + +If @var{@1@} is an array, the length of an element +of @var{@1@} is returned. + +Note that @var{@1@} need not be defined when this +intrinsic is invoked, since only the length, not +the content, of @var{@1@} is needed. + +@xref{Bit_Size Intrinsic}, for the function that determines +the size of its argument in bits. +") + +DEFDOC (TAN, "Tangent.", "\ +Returns the tangent of @var{@1@}, an angle measured +in radians. + +@xref{ATan Intrinsic}, for the inverse of this function. +") + +DEFDOC (DTAN, "Tangent (archaic).", ARCHAIC (TAN, Tan)) + +DEFDOC (TANH, "Hyperbolic tangent.", "\ +Returns the hyperbolic tangent of @var{@1@}. +") + +DEFDOC (DTANH, "Hyperbolic tangent (archaic).", ARCHAIC (TANH, TanH)) + +DEFDOC (SNGL, "Convert (archaic).", ARCHAIC (REAL, Real)) + +DEFDOC (SIN, "Sine.", "\ +Returns the sine of @var{@1@}, an angle measured +in radians. + +@xref{ASin Intrinsic}, for the inverse of this function. +") + +DEFDOC (CSIN, "Sine (archaic).", ARCHAIC (SIN, Sin)) + +DEFDOC (DSIN, "Sine (archaic).", ARCHAIC (SIN, Sin)) + +DEFDOC (CDSIN, "Sine (archaic).", ARCHAIC (SIN, Sin)) + +DEFDOC (SINH, "Hyperbolic sine.", "\ +Returns the hyperbolic sine of @var{@1@}. +") + +DEFDOC (DSINH, "Hyperbolic sine (archaic).", ARCHAIC (SINH, SinH)) + +DEFDOC (LSHIFT, "Left-shift bits.", "\ +Returns @var{@1@} shifted to the left +@var{@2@} bits. + +Although similar to the expression +@samp{@var{@1@}*(2**@var{@2@})}, there +are important differences. +For example, the sign of the result is +not necessarily the same as the sign of +@var{@1@}. + +Currently this intrinsic is defined assuming +the underlying representation of @var{@1@} +is as a two's-complement integer. +It is unclear at this point whether that +definition will apply when a different +representation is involved. + +@xref{LShift Intrinsic}, for the inverse of this function. + +@xref{IShft Intrinsic}, for information +on a more widely available left-shifting +intrinsic that is also more precisely defined. +") + +DEFDOC (RSHIFT, "Right-shift bits.", "\ +Returns @var{@1@} shifted to the right +@var{@2@} bits. + +Although similar to the expression +@samp{@var{@1@}/(2**@var{@2@})}, there +are important differences. +For example, the sign of the result is +undefined. + +Currently this intrinsic is defined assuming +the underlying representation of @var{@1@} +is as a two's-complement integer. +It is unclear at this point whether that +definition will apply when a different +representation is involved. + +@xref{RShift Intrinsic}, for the inverse of this function. + +@xref{IShft Intrinsic}, for information +on a more widely available right-shifting +intrinsic that is also more precisely defined. +") + +DEFDOC (LGE, "Lexically greater than or equal.", "\ +Returns @samp{.TRUE.} if @samp{@var{@1@}.GE.@var{@2@}}, +@samp{.FALSE.} otherwise. +@var{@1@} and @var{@2@} are interpreted as containing +ASCII character codes. +If either value contains a character not in the ASCII +character set, the result is processor dependent. + +If the @var{@1@} and @var{@2@} are not the same length, +the shorter is compared as if spaces were appended to +it to form a value that has the same length as the longer. + +The lexical comparison intrinsics @code{LGe}, @code{LGt}, +@code{LLe}, and @code{LLt} differ from the corresponding +intrinsic operators @code{.GE.}, @code{.GT.}, +@code{.LE.}, @code{.LT.}. +Because the ASCII collating sequence is assumed, +the following expressions always return @samp{.TRUE.}: + +@smallexample +LGE ('0', ' ') +LGE ('A', '0') +LGE ('a', 'A') +@end smallexample + +The following related expressions do @emph{not} always +return @samp{.TRUE.}, as they are not necessarily evaluated +assuming the arguments use ASCII encoding: + +@smallexample +'0' .GE. ' ' +'A' .GE. '0' +'a' .GE. 'A' +@end smallexample + +The same difference exists +between @code{LGt} and @code{.GT.}; +between @code{LLe} and @code{.LE.}; and +between @code{LLt} and @code{.LT.}. +") + +DEFDOC (LGT, "Lexically greater than.", "\ +Returns @samp{.TRUE.} if @samp{@var{@1@}.GT.@var{@2@}}, +@samp{.FALSE.} otherwise. +@var{@1@} and @var{@2@} are interpreted as containing +ASCII character codes. +If either value contains a character not in the ASCII +character set, the result is processor dependent. + +If the @var{@1@} and @var{@2@} are not the same length, +the shorter is compared as if spaces were appended to +it to form a value that has the same length as the longer. + +@xref{LGe Intrinsic}, for information on the distinction +between the @code{@0@} intrinsic and the @code{.GT.} +operator. +") + +DEFDOC (LLE, "Lexically less than or equal.", "\ +Returns @samp{.TRUE.} if @samp{@var{@1@}.LE.@var{@2@}}, +@samp{.FALSE.} otherwise. +@var{@1@} and @var{@2@} are interpreted as containing +ASCII character codes. +If either value contains a character not in the ASCII +character set, the result is processor dependent. + +If the @var{@1@} and @var{@2@} are not the same length, +the shorter is compared as if spaces were appended to +it to form a value that has the same length as the longer. + +@xref{LGe Intrinsic}, for information on the distinction +between the @code{@0@} intrinsic and the @code{.LE.} +operator. +") + +DEFDOC (LLT, "Lexically less than.", "\ +Returns @samp{.TRUE.} if @samp{@var{@1@}.LT.@var{@2@}}, +@samp{.FALSE.} otherwise. +@var{@1@} and @var{@2@} are interpreted as containing +ASCII character codes. +If either value contains a character not in the ASCII +character set, the result is processor dependent. + +If the @var{@1@} and @var{@2@} are not the same length, +the shorter is compared as if spaces were appended to +it to form a value that has the same length as the longer. + +@xref{LGe Intrinsic}, for information on the distinction +between the @code{@0@} intrinsic and the @code{.LT.} +operator. +") + +DEFDOC (SIGN, "Apply sign to magnitude.", "\ +Returns @samp{ABS(@var{@1@})*@var{s}}, where +@var{s} is +1 if @samp{@var{@2@}.GE.0}, +-1 otherwise. + +@xref{Abs Intrinsic}, for the function that returns +the magnitude of a value. +") + +DEFDOC (DSIGN, "Apply sign to magnitude (archaic).", ARCHAIC_2 (SIGN, Sign)) +DEFDOC (ISIGN, "Apply sign to magnitude (archaic).", ARCHAIC_2 (ISIGN, ISign)) + +DEFDOC (REAL, "Convert value to type @code{REAL(KIND=1)}.", "\ +Converts @var{@1@} to @code{REAL(KIND=1)}. + +Use of @code{@0@()} with a @code{COMPLEX} argument +(other than @code{COMPLEX(KIND=1)}) is restricted to the following case: + +@example +REAL(REAL(@1@)) +@end example + +@noindent +This expression converts the real part of @1@ to +@code{REAL(KIND=1)}. + +@xref{RealPart Intrinsic}, for information on a GNU Fortran +intrinsic that extracts the real part of an arbitrary +@code{COMPLEX} value. + +@xref{REAL() and AIMAG() of Complex}, for more information. +") + +DEFDOC (DREAL, "Convert value to type @code{REAL(KIND=2)}.", "\ +Converts @var{@1@} to @code{REAL(KIND=2)}. + +If @var{@1@} is type @code{COMPLEX}, its real part +is converted (if necessary) to @code{REAL(KIND=2)}, +and its imaginary part is disregarded. + +Although this intrinsic is not standard Fortran, +it is a popular extension offered by many compilers +that support @code{DOUBLE COMPLEX}, since it offers +the easiest way to extract the real part of a @code{DOUBLE COMPLEX} +value without using the Fortran 90 @code{REAL()} intrinsic +in a way that produces a return value inconsistent with +the way many FORTRAN 77 compilers handle @code{REAL()} of +a @code{DOUBLE COMPLEX} value. + +@xref{RealPart Intrinsic}, for information on a GNU Fortran +intrinsic that avoids these areas of confusion. + +@xref{REAL() and AIMAG() of Complex}, for more information on +this issue. +") + +DEFDOC (IMAGPART, "Extract imaginary part of complex.", "\ +The imaginary part of @var{@1@} is returned, without conversion. + +@emph{Note:} The way to do this in standard Fortran 90 +is @samp{AIMAG(@var{@1@})}. +However, when, for example, @var{@1@} is @code{DOUBLE COMPLEX}, +@samp{AIMAG(@var{@1@})} means something different for some compilers +that are not true Fortran 90 compilers but offer some +extensions standardized by Fortran 90 (such as the +@code{DOUBLE COMPLEX} type, also known as @code{COMPLEX(KIND=2)}). + +The advantage of @code{@0@()} is that, while not necessarily +more or less portable than @code{AIMAG()}, it is more likely to +cause a compiler that doesn't support it to produce a diagnostic +than generate incorrect code. + +@xref{REAL() and AIMAG() of Complex}, for more information. +") + +DEFDOC (COMPLEX, "Build complex value from real and@99@imaginary parts.", "\ +Returns a @code{COMPLEX} value that has @samp{@1@} and @samp{@2@} as its +real and imaginary parts, respectively. + +If @var{@1@} and @var{@2@} are the same type, and that type is not +@code{INTEGER}, no data conversion is performed, and the type of +the resulting value has the same kind value as the types +of @var{@1@} and @var{@2@}. + +If @var{@1@} and @var{@2@} are not the same type, the usual type-promotion +rules are applied to both, converting either or both to the +appropriate @code{REAL} type. +The type of the resulting value has the same kind value as the +type to which both @var{@1@} and @var{@2@} were converted, in this case. + +If @var{@1@} and @var{@2@} are both @code{INTEGER}, they are both converted +to @code{REAL(KIND=1)}, and the result of the @code{@0@()} +invocation is type @code{COMPLEX(KIND=1)}. + +@emph{Note:} The way to do this in standard Fortran 90 +is too hairy to describe here, but it is important to +note that @samp{CMPLX(D1,D2)} returns a @code{COMPLEX(KIND=1)} +result even if @samp{D1} and @samp{D2} are type @code{REAL(KIND=2)}. +Hence the availability of @code{COMPLEX()} in GNU Fortran. +") + +DEFDOC (LOC, "Address of entity in core.", "\ +The @code{LOC()} intrinsic works the +same way as the @code{%LOC()} construct. +@xref{%LOC(),,The @code{%LOC()} Construct}, for +more information. +") + +DEFDOC (REALPART, "Extract real part of complex.", "\ +The real part of @var{@1@} is returned, without conversion. + +@emph{Note:} The way to do this in standard Fortran 90 +is @samp{REAL(@var{@1@})}. +However, when, for example, @var{@1@} is @code{COMPLEX(KIND=2)}, +@samp{REAL(@var{@1@})} means something different for some compilers +that are not true Fortran 90 compilers but offer some +extensions standardized by Fortran 90 (such as the +@code{DOUBLE COMPLEX} type, also known as @code{COMPLEX(KIND=2)}). + +The advantage of @code{@0@()} is that, while not necessarily +more or less portable than @code{REAL()}, it is more likely to +cause a compiler that doesn't support it to produce a diagnostic +than generate incorrect code. + +@xref{REAL() and AIMAG() of Complex}, for more information. +") + +DEFDOC (GETARG, "Obtain command-line argument.", "\ +Sets @var{@2@} to the @var{@1@}-th command-line argument (or to all +blanks if there are fewer than @var{@2@} command-line arguments); +@code{CALL @0@(0, @var{value})} sets @var{value} to the name of the +program (on systems that support this feature). + +@xref{IArgC Intrinsic}, for information on how to get the number +of arguments. +") + +DEFDOC (ABORT, "Abort the program.", "\ +Prints a message and potentially causes a core dump via @code{abort(3)}. +") + +DEFDOC (EXIT, "Terminate the program.", "\ +Exit the program with status @var{@1@} after closing open Fortran +I/O units and otherwise behaving as @code{exit(2)}. +If @var{@1@} is omitted the canonical `success' value +will be returned to the system. +") + +DEFDOC (IARGC, "Obtain count of command-line arguments.", "\ +Returns the number of command-line arguments. + +This count does not include the specification of the program +name itself. +") + +DEFDOC (CTIME_func, "Convert time to Day Mon dd hh:mm:ss yyyy.", "\ +Converts @var{@1@}, a system time value, such as returned by +@code{TIME8()}, to a string of the form @samp{Sat Aug 19 18:13:14 1995}, +and returns that string as the function value. + +@xref{Time8 Intrinsic}. +") + +DEFDOC (CTIME_subr, "Convert time to Day Mon dd hh:mm:ss yyyy.", "\ +Converts @var{@2@}, a system time value, such as returned by +@code{TIME8()}, to a string of the form @samp{Sat Aug 19 18:13:14 1995}, +and returns that string in @var{@1@}. + +@xref{Time8 Intrinsic}. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine. +") + +DEFDOC (DATE, "Get current date as dd-Mon-yy.", "\ +Returns @var{@1@} in the form @samp{@var{dd}-@var{mmm}-@var{yy}}, +representing the numeric day of the month @var{dd}, a three-character +abbreviation of the month name @var{mmm} and the last two digits of +the year @var{yy}, e.g.@ @samp{25-Nov-96}. + +This intrinsic is not recommended, due to the year 2000 approaching. +@xref{CTime Intrinsic (subroutine)}, for information on obtaining more digits +for the current (or any) date. +") + +DEFDOC (DTIME_func, "Get elapsed time since last time.", "\ +Initially, return the number of seconds of runtime +since the start of the process's execution +as the function value, +and the user and system components of this in @samp{@var{@1@}(1)} +and @samp{@var{@1@}(2)} respectively. +The functions' value is equal to @samp{@var{@1@}(1) + @var{@1@}(2)}. + +Subsequent invocations of @samp{@0@()} return values accumulated since the +previous invocation. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. +") + +DEFDOC (DTIME_subr, "Get elapsed time since last time.", "\ +Initially, return the number of seconds of runtime +since the start of the process's execution +in @var{@1@}, +and the user and system components of this in @samp{@var{@2@}(1)} +and @samp{@var{@2@}(2)} respectively. +The value of @var{@1@} is equal to @samp{@var{@2@}(1) + @var{@2@}(2)}. + +Subsequent invocations of @samp{@0@()} set values based on accumulations +since the previous invocation. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine. +") + +DEFDOC (ETIME_func, "Get elapsed time for process.", "\ +Return the number of seconds of runtime +since the start of the process's execution +as the function value, +and the user and system components of this in @samp{@var{@1@}(1)} +and @samp{@var{@1@}(2)} respectively. +The functions' value is equal to @samp{@var{@1@}(1) + @var{@1@}(2)}. +") + +DEFDOC (ETIME_subr, "Get elapsed time for process.", "\ +Return the number of seconds of runtime +since the start of the process's execution +in @var{@1@}, +and the user and system components of this in @samp{@var{@2@}(1)} +and @samp{@var{@2@}(2)} respectively. +The value of @var{@1@} is equal to @samp{@var{@2@}(1) + @var{@2@}(2)}. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine. +") + +DEFDOC (FDATE_func, "Get current time as Day Mon dd hh:mm:ss yyyy.", "\ +Returns the current date (using the same format as @code{CTIME()}). + +Equivalent to: + +@example +CTIME(TIME8()) +@end example + +@xref{CTime Intrinsic (function)}. +") + +DEFDOC (FDATE_subr, "Get current time as Day Mon dd hh:mm:ss yyyy.", "\ +Returns the current date (using the same format as @code{CTIME()}) +in @var{@1@}. + +Equivalent to: + +@example +CALL CTIME(@var{@1@}, TIME8()) +@end example + +@xref{CTime Intrinsic (subroutine)}. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine. +") + +DEFDOC (GMTIME, "Convert time to GMT time info.", "\ +Given a system time value @var{@1@}, fills @var{@2@} with values +extracted from it appropriate to the GMT time zone using +@code{gmtime(3)}. + +The array elements are as follows: + +@enumerate +@item +Seconds after the minute, range 0--59 or 0--61 to allow for leap +seconds + +@item +Minutes after the hour, range 0--59 + +@item +Hours past midnight, range 0--23 + +@item +Day of month, range 0--31 + +@item +Number of months since January, range 0--12 + +@item +Years since 1900 + +@item +Number of days since Sunday, range 0--6 + +@item +Days since January 1 + +@item +Daylight savings indicator: positive if daylight savings is in effect, +zero if not, and negative if the information isn't available. +@end enumerate +") + +DEFDOC (LTIME, "Convert time to local time info.", "\ +Given a system time value @var{@1@}, fills @var{@2@} with values +extracted from it appropriate to the GMT time zone using +@code{localtime(3)}. + +The array elements are as follows: + +@enumerate +@item +Seconds after the minute, range 0--59 or 0--61 to allow for leap +seconds + +@item +Minutes after the hour, range 0--59 + +@item +Hours past midnight, range 0--23 + +@item +Day of month, range 0--31 + +@item +Number of months since January, range 0--12 + +@item +Years since 1900 + +@item +Number of days since Sunday, range 0--6 + +@item +Days since January 1 + +@item +Daylight savings indicator: positive if daylight savings is in effect, +zero if not, and negative if the information isn't available. +@end enumerate +") + +DEFDOC (IDATE_unix, "Get local time info.", "\ +Fills @var{@1@} with the numerical values at the current local time +of day, month (in the range 1--12), and year in elements 1, 2, and 3, +respectively. +The year has four significant digits. +") + +DEFDOC (IDATE_vxt, "Get local time info (VAX/VMS).", "\ +Returns the numerical values of the current local time. +The month (in the range 1--12) is returned in @var{@1@}, +the day (in the range 1--7) in @var{@2@}, +and the year in @var{@3@} (in the range 0--99). + +This intrinsic is not recommended, due to the year 2000 approaching. +") + +DEFDOC (ITIME, "Get local time of day.", "\ +Returns the current local time hour, minutes, and seconds in elements +1, 2, and 3 of @var{@1@}, respectively. +") + +DEFDOC (MCLOCK, "Get number of clock ticks for process.", "\ +Returns the number of clock ticks since the start of the process. +Supported on systems with @code{clock(3)} (q.v.). + +This intrinsic is not fully portable, such as to systems +with 32-bit @code{INTEGER} types but supporting times +wider than 32 bits. +@xref{MClock8 Intrinsic}, for information on a +similar intrinsic that might be portable to more +GNU Fortran implementations, though to fewer +Fortran compilers. + +If the system does not support @code{clock(3)}, +-1 is returned. +") + +DEFDOC (MCLOCK8, "Get number of clock ticks for process.", "\ +Returns the number of clock ticks since the start of the process. +Supported on systems with @code{clock(3)} (q.v.). + +No Fortran implementations other than GNU Fortran are +known to support this intrinsic at the time of this +writing. +@xref{MClock Intrinsic}, for information on a +similar intrinsic that might be portable to more Fortran +compilers, though to fewer GNU Fortran implementations. + +If the system does not support @code{clock(3)}, +-1 is returned. +") + +DEFDOC (SECNDS, "Get local time offset since midnight.", "\ +Returns the local time in seconds since midnight minus the value +@var{@1@}. +") + +DEFDOC (SECOND_func, "Get CPU time for process in seconds.", "\ +Returns the process's runtime in seconds---the same value as the +UNIX function @code{etime} returns. + +This routine is known from Cray Fortran. +") + +DEFDOC (SECOND_subr, "Get CPU time for process@99@in seconds.", "\ +Returns the process's runtime in seconds in @var{@1@}---the same value +as the UNIX function @code{etime} returns. + +This routine is known from Cray Fortran. @xref{Cpu_Time Intrinsic} +for a standard equivalent. +") + +DEFDOC (SYSTEM_CLOCK, "Get current system clock value.", "\ +Returns in @var{@1@} the current value of the system clock; this is +the value returned by the UNIX function @code{times(2)} +in this implementation, but +isn't in general. +@var{@2@} is the number of clock ticks per second and +@var{@3@} is the maximum value this can take, which isn't very useful +in this implementation since it's just the maximum C @code{unsigned +int} value. +") + +DEFDOC (CPU_TIME, "Get current CPU time.", "\ +Returns in @var{@1@} the current value of the system time. +This implementation of the Fortran 95 intrinsic is just an alias for +@code{second} @xref{Second Intrinsic (subroutine)}. +") + +DEFDOC (TIME8, "Get current time as time value.", "\ +Returns the current time encoded as a long integer +(in the manner of the UNIX function @code{time(3)}). +This value is suitable for passing to @code{CTIME}, +@code{GMTIME}, and @code{LTIME}. + +No Fortran implementations other than GNU Fortran are +known to support this intrinsic at the time of this +writing. +@xref{Time Intrinsic (UNIX)}, for information on a +similar intrinsic that might be portable to more Fortran +compilers, though to fewer GNU Fortran implementations. +") + +DEFDOC (TIME_unix, "Get current time as time value.", "\ +Returns the current time encoded as an integer +(in the manner of the UNIX function @code{time(3)}). +This value is suitable for passing to @code{CTIME}, +@code{GMTIME}, and @code{LTIME}. + +This intrinsic is not fully portable, such as to systems +with 32-bit @code{INTEGER} types but supporting times +wider than 32 bits. +@xref{Time8 Intrinsic}, for information on a +similar intrinsic that might be portable to more +GNU Fortran implementations, though to fewer +Fortran compilers. +") + +#define BES(num,n,val) "\ +Calculates the Bessel function of the " #num " kind of \ +order " #n " of @var{@" #val "@}.\n\ +See @code{bessel(3m)}, on whose implementation the \ +function depends.\ +" + +DEFDOC (BESJ0, "Bessel function.", BES (first, 0, 1)) +DEFDOC (BESJ1, "Bessel function.", BES (first, 1, 1)) +DEFDOC (BESJN, "Bessel function.", BES (first, @var{N}, 2)) +DEFDOC (BESY0, "Bessel function.", BES (second, 0, 1)) +DEFDOC (BESY1, "Bessel function.", BES (second, 1, 1)) +DEFDOC (BESYN, "Bessel function.", BES (second, @var{N}, 2)) +DEFDOC (DBESJ0, "Bessel function (archaic).", ARCHAIC (BESJ0, BesJ0)) +DEFDOC (DBESJ1, "Bessel function (archaic).", ARCHAIC (BESJ1, BesJ1)) +DEFDOC (DBESJN, "Bessel function (archaic).", ARCHAIC_2nd (BESJN, BesJN)) +DEFDOC (DBESY0, "Bessel function (archaic).", ARCHAIC (BESY0, BesY0)) +DEFDOC (DBESY1, "Bessel function (archaic).", ARCHAIC (BESY1, BesY1)) +DEFDOC (DBESYN, "Bessel function (archaic).", ARCHAIC_2nd (BESYN, BesYN)) + +DEFDOC (ERF, "Error function.", "\ +Returns the error function of @var{@1@}. +See @code{erf(3m)}, which provides the implementation. +") + +DEFDOC (ERFC, "Complementary error function.", "\ +Returns the complementary error function of @var{@1@}: +@samp{ERFC(R) = 1 - ERF(R)} (except that the result may be more +accurate than explicitly evaluating that formulae would give). +See @code{erfc(3m)}, which provides the implementation. +") + +DEFDOC (DERF, "Error function (archaic).", ARCHAIC (ERF, ErF)) +DEFDOC (DERFC, "Complementary error function (archaic).", ARCHAIC (ERFC, ErFC)) + +DEFDOC (IRAND, "Random number.", "\ +Returns a uniform quasi-random number up to a system-dependent limit. +If @var{@1@} is 0, the next number in sequence is returned; if +@var{@1@} is 1, the generator is restarted by calling the UNIX function +@samp{srand(0)}; if @var{@1@} has any other value, +it is used as a new seed with @code{srand()}. + +@xref{SRand Intrinsic}. + +@emph{Note:} As typically implemented (by the routine of the same +name in the C library), this random number generator is a very poor +one, though the BSD and GNU libraries provide a much better +implementation than the `traditional' one. +On a different system you almost certainly want to use something better. +") + +DEFDOC (RAND, "Random number.", "\ +Returns a uniform quasi-random number between 0 and 1. +If @var{@1@} is 0, the next number in sequence is returned; if +@var{@1@} is 1, the generator is restarted by calling @samp{srand(0)}; +if @var{@1@} has any other value, it is used as a new seed with +@code{srand}. + +@xref{SRand Intrinsic}. + +@emph{Note:} As typically implemented (by the routine of the same +name in the C library), this random number generator is a very poor +one, though the BSD and GNU libraries provide a much better +implementation than the `traditional' one. +On a different system you +almost certainly want to use something better. +") + +DEFDOC (SRAND, "Random seed.", "\ +Reinitialises the generator with the seed in @var{@1@}. +@xref{IRand Intrinsic}. +@xref{Rand Intrinsic}. +") + +DEFDOC (ACCESS, "Check file accessibility.", "\ +Checks file @var{@1@} for accessibility in the mode specified by @var{@2@} and +returns 0 if the file is accessible in that mode, otherwise an error +code if the file is inaccessible or @var{@2@} is invalid. +See @code{access(2)}. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{@1@}---otherwise, +trailing blanks in @var{@1@} are ignored. +@var{@2@} may be a concatenation of any of the following characters: + +@table @samp +@item r +Read permission + +@item w +Write permission + +@item x +Execute permission + +@item @kbd{SPC} +Existence +@end table +") + +DEFDOC (CHDIR_subr, "Change directory.", "\ +Sets the current working directory to be @var{@1@}. +If the @var{@2@} argument is supplied, it contains 0 +on success or a non-zero error code otherwise upon return. +See @code{chdir(3)}. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{@2@} argument. +") + +DEFDOC (CHDIR_func, "Change directory.", "\ +Sets the current working directory to be @var{@1@}. +Returns 0 on success or a non-zero error code. +See @code{chdir(3)}. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. +") + +DEFDOC (CHMOD_func, "Change file modes.", "\ +Changes the access mode of file @var{@1@} according to the +specification @var{@2@}, which is given in the format of +@code{chmod(1)}. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{@1@}---otherwise, +trailing blanks in @var{@1@} are ignored. +Currently, @var{@1@} must not contain the single quote +character. + +Returns 0 on success or a non-zero error code otherwise. + +Note that this currently works +by actually invoking @code{/bin/chmod} (or the @code{chmod} found when +the library was configured) and so may fail in some circumstances and +will, anyway, be slow. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. +") + +DEFDOC (CHMOD_subr, "Change file modes.", "\ +Changes the access mode of file @var{@1@} according to the +specification @var{@2@}, which is given in the format of +@code{chmod(1)}. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{@1@}---otherwise, +trailing blanks in @var{@1@} are ignored. +Currently, @var{@1@} must not contain the single quote +character. + +If the @var{@3@} argument is supplied, it contains +0 on success or a non-zero error code upon return. + +Note that this currently works +by actually invoking @code{/bin/chmod} (or the @code{chmod} found when +the library was configured) and so may fail in some circumstances and +will, anyway, be slow. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{@3@} argument. +") + +DEFDOC (GETCWD_func, "Get current working directory.", "\ +Places the current working directory in @var{@1@}. +Returns 0 on +success, otherwise a non-zero error code +(@code{ENOSYS} if the system does not provide @code{getcwd(3)} +or @code{getwd(3)}). +") + +DEFDOC (GETCWD_subr, "Get current working directory.", "\ +Places the current working directory in @var{@1@}. +If the @var{@2@} argument is supplied, it contains 0 +success or a non-zero error code upon return +(@code{ENOSYS} if the system does not provide @code{getcwd(3)} +or @code{getwd(3)}). + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{@2@} argument. +") + +DEFDOC (FSTAT_func, "Get file information.", "\ +Obtains data about the file open on Fortran I/O unit @var{@1@} and +places them in the array @var{@2@}. +The values in this array are +extracted from the @code{stat} structure as returned by +@code{fstat(2)} q.v., as follows: + +@enumerate +@item +File mode + +@item +Inode number + +@item +ID of device containing directory entry for file + +@item +Device id (if relevant) + +@item +Number of links + +@item +Owner's uid + +@item +Owner's gid + +@item +File size (bytes) + +@item +Last access time + +@item +Last modification time + +@item +Last file status change time + +@item +Preferred I/O block size + +@item +Number of blocks allocated +@end enumerate + +Not all these elements are relevant on all systems. +If an element is not relevant, it is returned as 0. + +Returns 0 on success or a non-zero error code. +") + +DEFDOC (FSTAT_subr, "Get file information.", "\ +Obtains data about the file open on Fortran I/O unit @var{@1@} and +places them in the array @var{@2@}. +The values in this array are +extracted from the @code{stat} structure as returned by +@code{fstat(2)} q.v., as follows: + +@enumerate +@item +File mode + +@item +Inode number + +@item +ID of device containing directory entry for file + +@item +Device id (if relevant) + +@item +Number of links + +@item +Owner's uid + +@item +Owner's gid + +@item +File size (bytes) + +@item +Last access time + +@item +Last modification time + +@item +Last file status change time + +@item +Preferred I/O block size + +@item +Number of blocks allocated +@end enumerate + +Not all these elements are relevant on all systems. +If an element is not relevant, it is returned as 0. + +If the @var{@3@} argument is supplied, it contains +0 on success or a non-zero error code upon return. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{@3@} argument. +") + +DEFDOC (LSTAT_func, "Get file information.", "\ +Obtains data about the given file @var{@1@} and places them in the array +@var{@2@}. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{@1@}---otherwise, +trailing blanks in @var{@1@} are ignored. +If @var{@1@} is a symbolic link it returns data on the +link itself, so the routine is available only on systems that support +symbolic links. +The values in this array are extracted from the +@code{stat} structure as returned by @code{fstat(2)} q.v., as follows: + +@enumerate +@item +File mode + +@item +Inode number + +@item +ID of device containing directory entry for file + +@item +Device id (if relevant) + +@item +Number of links + +@item +Owner's uid + +@item +Owner's gid + +@item +File size (bytes) + +@item +Last access time + +@item +Last modification time + +@item +Last file status change time + +@item +Preferred I/O block size + +@item +Number of blocks allocated +@end enumerate + +Not all these elements are relevant on all systems. +If an element is not relevant, it is returned as 0. + +Returns 0 on success or a non-zero error code +(@code{ENOSYS} if the system does not provide @code{lstat(2)}). +") + +DEFDOC (LSTAT_subr, "Get file information.", "\ +Obtains data about the given file @var{@1@} and places them in the array +@var{@2@}. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{@1@}---otherwise, +trailing blanks in @var{@1@} are ignored. +If @var{@1@} is a symbolic link it returns data on the +link itself, so the routine is available only on systems that support +symbolic links. +The values in this array are extracted from the +@code{stat} structure as returned by @code{fstat(2)} q.v., as follows: + +@enumerate +@item +File mode + +@item +Inode number + +@item +ID of device containing directory entry for file + +@item +Device id (if relevant) + +@item +Number of links + +@item +Owner's uid + +@item +Owner's gid + +@item +File size (bytes) + +@item +Last access time + +@item +Last modification time + +@item +Last file status change time + +@item +Preferred I/O block size + +@item +Number of blocks allocated +@end enumerate + +Not all these elements are relevant on all systems. +If an element is not relevant, it is returned as 0. + +If the @var{@3@} argument is supplied, it contains +0 on success or a non-zero error code upon return +(@code{ENOSYS} if the system does not provide @code{lstat(2)}). + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{@3@} argument. +") + +DEFDOC (STAT_func, "Get file information.", "\ +Obtains data about the given file @var{@1@} and places them in the array +@var{@2@}. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{@1@}---otherwise, +trailing blanks in @var{@1@} are ignored. +The values in this array are extracted from the +@code{stat} structure as returned by @code{fstat(2)} q.v., as follows: + +@enumerate +@item +File mode + +@item +Inode number + +@item +ID of device containing directory entry for file + +@item +Device id (if relevant) + +@item +Number of links + +@item +Owner's uid + +@item +Owner's gid + +@item +File size (bytes) + +@item +Last access time + +@item +Last modification time + +@item +Last file status change time + +@item +Preferred I/O block size + +@item +Number of blocks allocated +@end enumerate + +Not all these elements are relevant on all systems. +If an element is not relevant, it is returned as 0. + +Returns 0 on success or a non-zero error code. +") + +DEFDOC (STAT_subr, "Get file information.", "\ +Obtains data about the given file @var{@1@} and places them in the array +@var{@2@}. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{@1@}---otherwise, +trailing blanks in @var{@1@} are ignored. +The values in this array are extracted from the +@code{stat} structure as returned by @code{fstat(2)} q.v., as follows: + +@enumerate +@item +File mode + +@item +Inode number + +@item +ID of device containing directory entry for file + +@item +Device id (if relevant) + +@item +Number of links + +@item +Owner's uid + +@item +Owner's gid + +@item +File size (bytes) + +@item +Last access time + +@item +Last modification time + +@item +Last file status change time + +@item +Preferred I/O block size + +@item +Number of blocks allocated +@end enumerate + +Not all these elements are relevant on all systems. +If an element is not relevant, it is returned as 0. + +If the @var{@3@} argument is supplied, it contains +0 on success or a non-zero error code upon return. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{@3@} argument. +") + +DEFDOC (LINK_subr, "Make hard link in file system.", "\ +Makes a (hard) link from file @var{@1@} to @var{@2@}. +A null character (@samp{CHAR(0)}) marks the end of +the names in @var{@1@} and @var{@2@}---otherwise, +trailing blanks in @var{@1@} and @var{@2@} are ignored. +If the @var{@3@} argument is supplied, it contains +0 on success or a non-zero error code upon return. +See @code{link(2)}. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{@3@} argument. +") + +DEFDOC (LINK_func, "Make hard link in file system.", "\ +Makes a (hard) link from file @var{@1@} to @var{@2@}. +A null character (@samp{CHAR(0)}) marks the end of +the names in @var{@1@} and @var{@2@}---otherwise, +trailing blanks in @var{@1@} and @var{@2@} are ignored. +Returns 0 on success or a non-zero error code. +See @code{link(2)}. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. +") + +DEFDOC (SYMLNK_subr, "Make symbolic link in file system.", "\ +Makes a symbolic link from file @var{@1@} to @var{@2@}. +A null character (@samp{CHAR(0)}) marks the end of +the names in @var{@1@} and @var{@2@}---otherwise, +trailing blanks in @var{@1@} and @var{@2@} are ignored. +If the @var{@3@} argument is supplied, it contains +0 on success or a non-zero error code upon return +(@code{ENOSYS} if the system does not provide @code{symlink(2)}). + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{@3@} argument. +") + +DEFDOC (SYMLNK_func, "Make symbolic link in file system.", "\ +Makes a symbolic link from file @var{@1@} to @var{@2@}. +A null character (@samp{CHAR(0)}) marks the end of +the names in @var{@1@} and @var{@2@}---otherwise, +trailing blanks in @var{@1@} and @var{@2@} are ignored. +Returns 0 on success or a non-zero error code +(@code{ENOSYS} if the system does not provide @code{symlink(2)}). + +Due to the side effects performed by this intrinsic, the function +form is not recommended. +") + +DEFDOC (RENAME_subr, "Rename file.", "\ +Renames the file @var{@1@} to @var{@2@}. +A null character (@samp{CHAR(0)}) marks the end of +the names in @var{@1@} and @var{@2@}---otherwise, +trailing blanks in @var{@1@} and @var{@2@} are ignored. +See @code{rename(2)}. +If the @var{@3@} argument is supplied, it contains +0 on success or a non-zero error code upon return. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{@3@} argument. +") + +DEFDOC (RENAME_func, "Rename file.", "\ +Renames the file @var{@1@} to @var{@2@}. +A null character (@samp{CHAR(0)}) marks the end of +the names in @var{@1@} and @var{@2@}---otherwise, +trailing blanks in @var{@1@} and @var{@2@} are ignored. +See @code{rename(2)}. +Returns 0 on success or a non-zero error code. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. +") + +DEFDOC (UMASK_subr, "Set file creation permissions mask.", "\ +Sets the file creation mask to @var{@1@} and returns the old value in +argument @var{@2@} if it is supplied. +See @code{umask(2)}. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine. +") + +DEFDOC (UMASK_func, "Set file creation permissions mask.", "\ +Sets the file creation mask to @var{@1@} and returns the old value. +See @code{umask(2)}. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. +") + +DEFDOC (UNLINK_subr, "Unlink file.", "\ +Unlink the file @var{@1@}. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{@1@}---otherwise, +trailing blanks in @var{@1@} are ignored. +If the @var{@2@} argument is supplied, it contains +0 on success or a non-zero error code upon return. +See @code{unlink(2)}. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{@2@} argument. +") + +DEFDOC (UNLINK_func, "Unlink file.", "\ +Unlink the file @var{@1@}. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{@1@}---otherwise, +trailing blanks in @var{@1@} are ignored. +Returns 0 on success or a non-zero error code. +See @code{unlink(2)}. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. +") + +DEFDOC (GERROR, "Get error message for last error.", "\ +Returns the system error message corresponding to the last system +error (C @code{errno}). +") + +DEFDOC (IERRNO, "Get error number for last error.", "\ +Returns the last system error number (corresponding to the C +@code{errno}). +") + +DEFDOC (PERROR, "Print error message for last error.", "\ +Prints (on the C @code{stderr} stream) a newline-terminated error +message corresponding to the last system error. +This is prefixed by @var{@1@}, a colon and a space. +See @code{perror(3)}. +") + +DEFDOC (GETGID, "Get process group id.", "\ +Returns the group id for the current process. +") + +DEFDOC (GETUID, "Get process user id.", "\ +Returns the user id for the current process. +") + +DEFDOC (GETPID, "Get process id.", "\ +Returns the process id for the current process. +") + +DEFDOC (GETENV, "Get environment variable.", "\ +Sets @var{@2@} to the value of environment variable given by the +value of @var{@1@} (@code{$name} in shell terms) or to blanks if +@code{$name} has not been set. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{@1@}---otherwise, +trailing blanks in @var{@1@} are ignored. +") + +DEFDOC (GETLOG, "Get login name.", "\ +Returns the login name for the process in @var{@1@}. +") + +DEFDOC (HOSTNM_func, "Get host name.", "\ +Fills @var{@1@} with the system's host name returned by +@code{gethostname(2)}, returning 0 on success or a non-zero error code +(@code{ENOSYS} if the system does not provide @code{gethostname(2)}). + +This intrinsic is not available on all systems. +") + +DEFDOC (HOSTNM_subr, "Get host name.", "\ +Fills @var{@1@} with the system's host name returned by +@code{gethostname(2)}. +If the @var{@2@} argument is supplied, it contains +0 on success or a non-zero error code upon return +(@code{ENOSYS} if the system does not provide @code{gethostname(2)}). + +This intrinsic is not available on all systems. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{@2@} argument. +") + +/* Fixme: stream I/O */ + +DEFDOC (FLUSH, "Flush buffered output.", "\ +Flushes Fortran unit(s) currently open for output. +Without the optional argument, all such units are flushed, +otherwise just the unit specified by @var{@1@}. + +Some non-GNU implementations of Fortran provide this intrinsic +as a library procedure that might or might not support the +(optional) @var{@1@} argument. +") + +DEFDOC (FNUM, "Get file descriptor from Fortran unit number.", "\ +Returns the Unix file descriptor number corresponding to the open +Fortran I/O unit @var{@1@}. +This could be passed to an interface to C I/O routines. +") + +#define IOWARN " +Stream I/O should not be mixed with normal record-oriented (formatted or +unformatted) I/O on the same unit; the results are unpredictable. +" + +DEFDOC (FGET_func, "Read a character from unit 5 stream-wise.", "\ +Reads a single character into @var{@1@} in stream mode from unit 5 +(by-passing normal formatted input) using @code{getc(3)}. +Returns 0 on +success, @minus{}1 on end-of-file, and the error code from +@code{ferror(3)} otherwise. +" IOWARN) + +DEFDOC (FGET_subr, "Read a character from unit 5 stream-wise.", "\ +Reads a single character into @var{@1@} in stream mode from unit 5 +(by-passing normal formatted output) using @code{getc(3)}. +Returns in +@var{@2@} 0 on success, @minus{}1 on end-of-file, and the error code +from @code{ferror(3)} otherwise. +" IOWARN) + +DEFDOC (FGETC_func, "Read a character stream-wise.", "\ +Reads a single character into @var{@2@} in stream mode from unit @var{@1@} +(by-passing normal formatted output) using @code{getc(3)}. +Returns 0 on +success, @minus{}1 on end-of-file, and the error code from +@code{ferror(3)} otherwise. +" IOWARN) + +DEFDOC (FGETC_subr, "Read a character stream-wise.", "\ +Reads a single character into @var{@2@} in stream mode from unit @var{@1@} +(by-passing normal formatted output) using @code{getc(3)}. +Returns in +@var{@3@} 0 on success, @minus{}1 on end-of-file, and the error code from +@code{ferror(3)} otherwise. +" IOWARN) + +DEFDOC (FPUT_func, "Write a character to unit 6 stream-wise.", "\ +Writes the single character @var{@1@} in stream mode to unit 6 +(by-passing normal formatted output) using @code{getc(3)}. +Returns 0 on +success, the error code from @code{ferror(3)} otherwise. +" IOWARN) + +DEFDOC (FPUT_subr, "Write a character to unit 6 stream-wise.", "\ +Writes the single character @var{@1@} in stream mode to unit 6 +(by-passing normal formatted output) using @code{putc(3)}. +Returns in +@var{@2@} 0 on success, the error code from @code{ferror(3)} otherwise. +" IOWARN) + +DEFDOC (FPUTC_func, "Write a character stream-wise.", "\ +Writes the single character @var{@2@} in stream mode to unit @var{@1@} +(by-passing normal formatted output) using @code{putc(3)}. +Returns 0 on +success, the error code from @code{ferror(3)} otherwise. +" IOWARN) + +DEFDOC (FPUTC_subr, "Write a character stream-wise.", "\ +Writes the single character @var{@1@} in stream mode to unit 6 +(by-passing normal formatted output) using @code{putc(3)}. +Returns in +@var{@2@} 0 on success, the error code from @code{ferror(3)} otherwise. +" IOWARN) + +DEFDOC (FSEEK, "Position file (low-level).", "\ +Attempts to move Fortran unit @var{@1@} to the specified +@var{Offset}: absolute offset if @var{@2@}=0; relative to the +current offset if @var{@2@}=1; relative to the end of the file if +@var{@2@}=2. +It branches to label @var{@3@} if @var{@1@} is +not open or if the call otherwise fails. +") + +DEFDOC (FTELL_func, "Get file position (low-level).", "\ +Returns the current offset of Fortran unit @var{@1@} +(or @minus{}1 if @var{@1@} is not open). +") + +DEFDOC (FTELL_subr, "Get file position (low-level).", "\ +Sets @var{@2@} to the current offset of Fortran unit @var{@1@} +(or to @minus{}1 if @var{@1@} is not open). + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine. +") + +DEFDOC (ISATTY, "Is unit connected to a terminal?", "\ +Returns @code{.TRUE.} if and only if the Fortran I/O unit +specified by @var{@1@} is connected +to a terminal device. +See @code{isatty(3)}. +") + +DEFDOC (TTYNAM_func, "Get name of terminal device for unit.", "\ +Returns the name of the terminal device open on logical unit +@var{@1@} or a blank string if @var{@1@} is not connected to a +terminal. +") + +DEFDOC (TTYNAM_subr, "Get name of terminal device for unit.", "\ +Sets @var{@1@} to the name of the terminal device open on logical unit +@var{@2@} or a blank string if @var{@2@} is not connected to a +terminal. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine. +") + +DEFDOC (SIGNAL_subr, "Muck with signal handling.", "\ +If @var{@2@} is a an @code{EXTERNAL} routine, arranges for it to be +invoked with a single integer argument (of system-dependent length) +when signal @var{@1@} occurs. +If @var{@1@} is an integer, it can be +used to turn off handling of signal @var{@2@} or revert to its default +action. +See @code{signal(2)}. + +Note that @var{@2@} will be called using C conventions, so its value in +Fortran terms is obtained by applying @code{%LOC()} (or @var{LOC()}) to it. + +The value returned by @code{signal(2)} is written to @var{@3@}, if +that argument is supplied. +Otherwise the return value is ignored. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{@3@} argument. +") + +DEFDOC (SIGNAL_func, "Muck with signal handling.", "\ +If @var{@2@} is a an @code{EXTERNAL} routine, arranges for it to be +invoked with a single integer argument (of system-dependent length) +when signal @var{@1@} occurs. +If @var{@1@} is an integer, it can be +used to turn off handling of signal @var{@2@} or revert to its default +action. +See @code{signal(2)}. + +Note that @var{@2@} will be called using C conventions, so its value in +Fortran terms is obtained by applying @code{%LOC()} (or @var{LOC()}) to it. + +The value returned by @code{signal(2)} is returned. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. +") + +DEFDOC (KILL_func, "Signal a process.", "\ +Sends the signal specified by @var{@2@} to the process @var{@1@}. +Returns 0 on success or a non-zero error code. +See @code{kill(2)}. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. +") + +DEFDOC (KILL_subr, "Signal a process.", "\ +Sends the signal specified by @var{@2@} to the process @var{@1@}. +If the @var{@3@} argument is supplied, it contains +0 on success or a non-zero error code upon return. +See @code{kill(2)}. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{@3@} argument. +") + +DEFDOC (LNBLNK, "Get last non-blank character in string.", "\ +Returns the index of the last non-blank character in @var{@1@}. +@code{LNBLNK} and @code{LEN_TRIM} are equivalent. +") + +DEFDOC (SLEEP, "Sleep for a specified time.", "\ +Causes the process to pause for @var{@1@} seconds. +See @code{sleep(2)}. +") + +DEFDOC (SYSTEM_subr, "Invoke shell (system) command.", "\ +Passes the command @var{@1@} to a shell (see @code{system(3)}). +If argument @var{@2@} is present, it contains the value returned by +@code{system(3)}, presumably 0 if the shell command succeeded. +Note that which shell is used to invoke the command is system-dependent +and environment-dependent. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{@2@} argument. +") + +DEFDOC (SYSTEM_func, "Invoke shell (system) command.", "\ +Passes the command @var{@1@} to a shell (see @code{system(3)}). +Returns the value returned by +@code{system(3)}, presumably 0 if the shell command succeeded. +Note that which shell is used to invoke the command is system-dependent +and environment-dependent. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. +However, the function form can be valid in cases where the +actual side effects performed by the call are unimportant to +the application. + +For example, on a UNIX system, @samp{SAME = SYSTEM('cmp a b')} +does not perform any side effects likely to be important to the +program, so the programmer would not care if the actual system +call (and invocation of @code{cmp}) was optimized away in a situation +where the return value could be determined otherwise, or was not +actually needed (@samp{SAME} not actually referenced after the +sample assignment statement). +") + +DEFDOC (TIME_vxt, "Get the time as a character value.", "\ +Returns in @var{@1@} a character representation of the current time as +obtained from @code{ctime(3)}. + +@xref{Fdate Intrinsic (subroutine)} for an equivalent routine. +") + +DEFDOC (IBCLR, "Clear a bit.", "\ +Returns the value of @var{@1@} with bit @var{@2@} cleared (set to +zero). +@xref{BTest Intrinsic} for information on bit positions. +") + +DEFDOC (IBSET, "Set a bit.", "\ +Returns the value of @var{@1@} with bit @var{@2@} set (to one). +@xref{BTest Intrinsic} for information on bit positions. +") + +DEFDOC (IBITS, "Extract a bit subfield of a variable.", "\ +Extracts a subfield of length @var{@3@} from @var{@1@}, starting from +bit position @var{@2@} and extending left for @var{@3@} bits. +The result is right-justified and the remaining bits are zeroed. +The value +of @samp{@var{@2@}+@var{@3@}} must be less than or equal to the value +@samp{BIT_SIZE(@var{@1@})}. +@xref{Bit_Size Intrinsic}. +") + +DEFDOC (ISHFT, "Logical bit shift.", "\ +All bits representing @var{@1@} are shifted @var{@2@} places. +@samp{@var{@2@}.GT.0} indicates a left shift, @samp{@var{@2@}.EQ.0} +indicates no shift and @samp{@var{@2@}.LT.0} indicates a right shift. +If the absolute value of the shift count is greater than +@samp{BIT_SIZE(@var{@1@})}, the result is undefined. +Bits shifted out from the left end or the right end, as the case may be, +are lost. +Zeros are shifted in from the opposite end. + +@xref{IShftC Intrinsic} for the circular-shift equivalent. +") + +DEFDOC (ISHFTC, "Circular bit shift.", "\ +The rightmost @var{@3@} bits of the argument @var{@1@} +are shifted circularly @var{@2@} +places, i.e.@ the bits shifted out of one end are shifted into +the opposite end. +No bits are lost. +The unshifted bits of the result are the same as +the unshifted bits of @var{@1@}. +The absolute value of the argument @var{@2@} +must be less than or equal to @var{@3@}. +The value of @var{@3@} must be greater than or equal to one and less than +or equal to @samp{BIT_SIZE(@var{@1@})}. + +@xref{IShft Intrinsic} for the logical shift equivalent. +") + +DEFDOC (MVBITS, "Moving a bit field.", "\ +Moves @var{@3@} bits from positions @var{@2@} through +@samp{@var{@2@}+@var{@3@}-1} of @var{@1@} to positions @var{@5@} through +@samp{@var{@2@}+@var{@3@}-1} of @var{@4@}. The portion of argument +@var{@4@} not affected by the movement of bits is unchanged. Arguments +@var{@1@} and @var{@4@} are permitted to be the same numeric storage +unit. The values of @samp{@var{@2@}+@var{@3@}} and +@samp{@var{@5@}+@var{@3@}} must be less than or equal to +@samp{BIT_SIZE(@var{@1@})}. +") + +DEFDOC (INDEX, "Locate a CHARACTER substring.", "\ +Returns the position of the start of the first occurrence of string +@var{@2@} as a substring in @var{@1@}, counting from one. +If @var{@2@} doesn't occur in @var{@1@}, zero is returned. +") + diff --git a/gcc/f/intdoc.texi b/gcc/f/intdoc.texi new file mode 100644 index 000000000000..1d961d83d920 --- /dev/null +++ b/gcc/f/intdoc.texi @@ -0,0 +1,10570 @@ +@menu +@ifset familyF2U +* Abort Intrinsic:: Abort the program. +@end ifset +@ifset familyF77 +* Abs Intrinsic:: Absolute value. +@end ifset +@ifset familyF2U +* Access Intrinsic:: Check file accessibility. +@end ifset +@ifset familyASC +* AChar Intrinsic:: ASCII character from code. +@end ifset +@ifset familyF77 +* ACos Intrinsic:: Arc cosine. +@end ifset +@ifset familyVXT +* ACosD Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF90 +* AdjustL Intrinsic:: (Reserved for future use.) +* AdjustR Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* AImag Intrinsic:: Convert/extract imaginary part of complex. +@end ifset +@ifset familyVXT +* AIMax0 Intrinsic:: (Reserved for future use.) +* AIMin0 Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* AInt Intrinsic:: Truncate to whole number. +@end ifset +@ifset familyVXT +* AJMax0 Intrinsic:: (Reserved for future use.) +* AJMin0 Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2U +* Alarm Intrinsic:: +@end ifset +@ifset familyF90 +* All Intrinsic:: (Reserved for future use.) +* Allocated Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* ALog Intrinsic:: Natural logarithm (archaic). +* ALog10 Intrinsic:: Natural logarithm (archaic). +* AMax0 Intrinsic:: Maximum value (archaic). +* AMax1 Intrinsic:: Maximum value (archaic). +* AMin0 Intrinsic:: Minimum value (archaic). +* AMin1 Intrinsic:: Minimum value (archaic). +* AMod Intrinsic:: Remainder (archaic). +@end ifset +@ifset familyF2C +* And Intrinsic:: Boolean AND. +@end ifset +@ifset familyF77 +* ANInt Intrinsic:: Round to nearest whole number. +@end ifset +@ifset familyF90 +* Any Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* ASin Intrinsic:: Arc sine. +@end ifset +@ifset familyVXT +* ASinD Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF90 +* Associated Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* ATan Intrinsic:: Arc tangent. +* ATan2 Intrinsic:: Arc tangent. +@end ifset +@ifset familyVXT +* ATan2D Intrinsic:: (Reserved for future use.) +* ATanD Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2U +* BesJ0 Intrinsic:: Bessel function. +* BesJ1 Intrinsic:: Bessel function. +* BesJN Intrinsic:: Bessel function. +* BesY0 Intrinsic:: Bessel function. +* BesY1 Intrinsic:: Bessel function. +* BesYN Intrinsic:: Bessel function. +@end ifset +@ifset familyVXT +* BITest Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF90 +* Bit_Size Intrinsic:: Number of bits in argument's type. +@end ifset +@ifset familyVXT +* BJTest Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyMIL +* BTest Intrinsic:: Test bit. +@end ifset +@ifset familyF77 +* CAbs Intrinsic:: Absolute value (archaic). +* CCos Intrinsic:: Cosine (archaic). +@end ifset +@ifset familyFVZ +* CDAbs Intrinsic:: Absolute value (archaic). +* CDCos Intrinsic:: Cosine (archaic). +* CDExp Intrinsic:: Exponential (archaic). +* CDLog Intrinsic:: Natural logarithm (archaic). +* CDSin Intrinsic:: Sine (archaic). +* CDSqRt Intrinsic:: Square root (archaic). +@end ifset +@ifset familyF90 +* Ceiling Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* CExp Intrinsic:: Exponential (archaic). +* Char Intrinsic:: Character from code. +@end ifset +@ifset familyF2U +* ChDir Intrinsic (subroutine):: Change directory. +@end ifset +@ifset familyBADU77 +* ChDir Intrinsic (function):: Change directory. +@end ifset +@ifset familyF2U +* ChMod Intrinsic (subroutine):: Change file modes. +@end ifset +@ifset familyBADU77 +* ChMod Intrinsic (function):: Change file modes. +@end ifset +@ifset familyF77 +* CLog Intrinsic:: Natural logarithm (archaic). +* Cmplx Intrinsic:: Construct @code{COMPLEX(KIND=1)} value. +@end ifset +@ifset familyGNU +* Complex Intrinsic:: Build complex value from real and + imaginary parts. +@end ifset +@ifset familyF77 +* Conjg Intrinsic:: Complex conjugate. +* Cos Intrinsic:: Cosine. +@end ifset +@ifset familyVXT +* CosD Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* CosH Intrinsic:: Hyperbolic cosine. +@end ifset +@ifset familyF90 +* Count Intrinsic:: (Reserved for future use.) +* Cpu_Time Intrinsic:: Get current CPU time. +* CShift Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* CSin Intrinsic:: Sine (archaic). +* CSqRt Intrinsic:: Square root (archaic). +@end ifset +@ifset familyF2U +* CTime Intrinsic (subroutine):: Convert time to Day Mon dd hh:mm:ss yyyy. +* CTime Intrinsic (function):: Convert time to Day Mon dd hh:mm:ss yyyy. +@end ifset +@ifset familyF77 +* DAbs Intrinsic:: Absolute value (archaic). +* DACos Intrinsic:: Arc cosine (archaic). +@end ifset +@ifset familyVXT +* DACosD Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* DASin Intrinsic:: Arc sine (archaic). +@end ifset +@ifset familyVXT +* DASinD Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* DATan Intrinsic:: Arc tangent (archaic). +* DATan2 Intrinsic:: Arc tangent (archaic). +@end ifset +@ifset familyVXT +* DATan2D Intrinsic:: (Reserved for future use.) +* DATanD Intrinsic:: (Reserved for future use.) +* Date Intrinsic:: Get current date as dd-Mon-yy. +@end ifset +@ifset familyF90 +* Date_and_Time Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2U +* DbesJ0 Intrinsic:: Bessel function (archaic). +* DbesJ1 Intrinsic:: Bessel function (archaic). +* DbesJN Intrinsic:: Bessel function (archaic). +* DbesY0 Intrinsic:: Bessel function (archaic). +* DbesY1 Intrinsic:: Bessel function (archaic). +* DbesYN Intrinsic:: Bessel function (archaic). +@end ifset +@ifset familyF77 +* Dble Intrinsic:: Convert to double precision. +@end ifset +@ifset familyVXT +* DbleQ Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyFVZ +* DCmplx Intrinsic:: Construct @code{COMPLEX(KIND=2)} value. +* DConjg Intrinsic:: Complex conjugate (archaic). +@end ifset +@ifset familyF77 +* DCos Intrinsic:: Cosine (archaic). +@end ifset +@ifset familyVXT +* DCosD Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* DCosH Intrinsic:: Hyperbolic cosine (archaic). +* DDiM Intrinsic:: Difference magnitude (archaic). +@end ifset +@ifset familyF2U +* DErF Intrinsic:: Error function (archaic). +* DErFC Intrinsic:: Complementary error function (archaic). +@end ifset +@ifset familyF77 +* DExp Intrinsic:: Exponential (archaic). +@end ifset +@ifset familyFVZ +* DFloat Intrinsic:: Conversion (archaic). +@end ifset +@ifset familyVXT +* DFlotI Intrinsic:: (Reserved for future use.) +* DFlotJ Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF90 +* Digits Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* DiM Intrinsic:: Difference magnitude (non-negative subtract). +@end ifset +@ifset familyFVZ +* DImag Intrinsic:: Convert/extract imaginary part of complex (archaic). +@end ifset +@ifset familyF77 +* DInt Intrinsic:: Truncate to whole number (archaic). +* DLog Intrinsic:: Natural logarithm (archaic). +* DLog10 Intrinsic:: Natural logarithm (archaic). +* DMax1 Intrinsic:: Maximum value (archaic). +* DMin1 Intrinsic:: Minimum value (archaic). +* DMod Intrinsic:: Remainder (archaic). +* DNInt Intrinsic:: Round to nearest whole number (archaic). +@end ifset +@ifset familyF90 +* Dot_Product Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* DProd Intrinsic:: Double-precision product. +@end ifset +@ifset familyVXT +* DReal Intrinsic:: Convert value to type @code{REAL(KIND=2)}. +@end ifset +@ifset familyF77 +* DSign Intrinsic:: Apply sign to magnitude (archaic). +* DSin Intrinsic:: Sine (archaic). +@end ifset +@ifset familyVXT +* DSinD Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* DSinH Intrinsic:: Hyperbolic sine (archaic). +* DSqRt Intrinsic:: Square root (archaic). +* DTan Intrinsic:: Tangent (archaic). +@end ifset +@ifset familyVXT +* DTanD Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* DTanH Intrinsic:: Hyperbolic tangent (archaic). +@end ifset +@ifset familyF2U +* Dtime Intrinsic (subroutine):: Get elapsed time since last time. +@end ifset +@ifset familyBADU77 +* Dtime Intrinsic (function):: Get elapsed time since last time. +@end ifset +@ifset familyF90 +* EOShift Intrinsic:: (Reserved for future use.) +* Epsilon Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2U +* ErF Intrinsic:: Error function. +* ErFC Intrinsic:: Complementary error function. +* ETime Intrinsic (subroutine):: Get elapsed time for process. +* ETime Intrinsic (function):: Get elapsed time for process. +* Exit Intrinsic:: Terminate the program. +@end ifset +@ifset familyF77 +* Exp Intrinsic:: Exponential. +@end ifset +@ifset familyF90 +* Exponent Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2U +* Fdate Intrinsic (subroutine):: Get current time as Day Mon dd hh:mm:ss yyyy. +* Fdate Intrinsic (function):: Get current time as Day Mon dd hh:mm:ss yyyy. +* FGet Intrinsic (subroutine):: Read a character from unit 5 stream-wise. +@end ifset +@ifset familyBADU77 +* FGet Intrinsic (function):: Read a character from unit 5 stream-wise. +@end ifset +@ifset familyF2U +* FGetC Intrinsic (subroutine):: Read a character stream-wise. +@end ifset +@ifset familyBADU77 +* FGetC Intrinsic (function):: Read a character stream-wise. +@end ifset +@ifset familyF77 +* Float Intrinsic:: Conversion (archaic). +@end ifset +@ifset familyVXT +* FloatI Intrinsic:: (Reserved for future use.) +* FloatJ Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF90 +* Floor Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2U +* Flush Intrinsic:: Flush buffered output. +* FNum Intrinsic:: Get file descriptor from Fortran unit number. +* FPut Intrinsic (subroutine):: Write a character to unit 6 stream-wise. +@end ifset +@ifset familyBADU77 +* FPut Intrinsic (function):: Write a character to unit 6 stream-wise. +@end ifset +@ifset familyF2U +* FPutC Intrinsic (subroutine):: Write a character stream-wise. +@end ifset +@ifset familyBADU77 +* FPutC Intrinsic (function):: Write a character stream-wise. +@end ifset +@ifset familyF90 +* Fraction Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2U +* FSeek Intrinsic:: Position file (low-level). +* FStat Intrinsic (subroutine):: Get file information. +* FStat Intrinsic (function):: Get file information. +* FTell Intrinsic (subroutine):: Get file position (low-level). +* FTell Intrinsic (function):: Get file position (low-level). +* GError Intrinsic:: Get error message for last error. +* GetArg Intrinsic:: Obtain command-line argument. +* GetCWD Intrinsic (subroutine):: Get current working directory. +* GetCWD Intrinsic (function):: Get current working directory. +* GetEnv Intrinsic:: Get environment variable. +* GetGId Intrinsic:: Get process group id. +* GetLog Intrinsic:: Get login name. +* GetPId Intrinsic:: Get process id. +* GetUId Intrinsic:: Get process user id. +* GMTime Intrinsic:: Convert time to GMT time info. +* HostNm Intrinsic (subroutine):: Get host name. +* HostNm Intrinsic (function):: Get host name. +@end ifset +@ifset familyF90 +* Huge Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* IAbs Intrinsic:: Absolute value (archaic). +@end ifset +@ifset familyASC +* IAChar Intrinsic:: ASCII code for character. +@end ifset +@ifset familyMIL +* IAnd Intrinsic:: Boolean AND. +@end ifset +@ifset familyF2U +* IArgC Intrinsic:: Obtain count of command-line arguments. +@end ifset +@ifset familyMIL +* IBClr Intrinsic:: Clear a bit. +* IBits Intrinsic:: Extract a bit subfield of a variable. +* IBSet Intrinsic:: Set a bit. +@end ifset +@ifset familyF77 +* IChar Intrinsic:: Code for character. +@end ifset +@ifset familyF2U +* IDate Intrinsic (UNIX):: Get local time info. +@end ifset +@ifset familyVXT +* IDate Intrinsic (VXT):: Get local time info (VAX/VMS). +@end ifset +@ifset familyF77 +* IDiM Intrinsic:: Difference magnitude (archaic). +* IDInt Intrinsic:: Convert to @code{INTEGER} value truncated + to whole number (archaic). +* IDNInt Intrinsic:: Convert to @code{INTEGER} value rounded + to nearest whole number (archaic). +@end ifset +@ifset familyMIL +* IEOr Intrinsic:: Boolean XOR. +@end ifset +@ifset familyF2U +* IErrNo Intrinsic:: Get error number for last error. +@end ifset +@ifset familyF77 +* IFix Intrinsic:: Conversion (archaic). +@end ifset +@ifset familyVXT +* IIAbs Intrinsic:: (Reserved for future use.) +* IIAnd Intrinsic:: (Reserved for future use.) +* IIBClr Intrinsic:: (Reserved for future use.) +* IIBits Intrinsic:: (Reserved for future use.) +* IIBSet Intrinsic:: (Reserved for future use.) +* IIDiM Intrinsic:: (Reserved for future use.) +* IIDInt Intrinsic:: (Reserved for future use.) +* IIDNnt Intrinsic:: (Reserved for future use.) +* IIEOr Intrinsic:: (Reserved for future use.) +* IIFix Intrinsic:: (Reserved for future use.) +* IInt Intrinsic:: (Reserved for future use.) +* IIOr Intrinsic:: (Reserved for future use.) +* IIQint Intrinsic:: (Reserved for future use.) +* IIQNnt Intrinsic:: (Reserved for future use.) +* IIShftC Intrinsic:: (Reserved for future use.) +* IISign Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2C +* Imag Intrinsic:: Extract imaginary part of complex. +@end ifset +@ifset familyGNU +* ImagPart Intrinsic:: Extract imaginary part of complex. +@end ifset +@ifset familyVXT +* IMax0 Intrinsic:: (Reserved for future use.) +* IMax1 Intrinsic:: (Reserved for future use.) +* IMin0 Intrinsic:: (Reserved for future use.) +* IMin1 Intrinsic:: (Reserved for future use.) +* IMod Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* Index Intrinsic:: Locate a CHARACTER substring. +@end ifset +@ifset familyVXT +* INInt Intrinsic:: (Reserved for future use.) +* INot Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* Int Intrinsic:: Convert to @code{INTEGER} value truncated + to whole number. +@end ifset +@ifset familyGNU +* Int2 Intrinsic:: Convert to @code{INTEGER(KIND=6)} value + truncated to whole number. +* Int8 Intrinsic:: Convert to @code{INTEGER(KIND=2)} value + truncated to whole number. +@end ifset +@ifset familyMIL +* IOr Intrinsic:: Boolean OR. +@end ifset +@ifset familyF2U +* IRand Intrinsic:: Random number. +* IsaTty Intrinsic:: Is unit connected to a terminal? +@end ifset +@ifset familyMIL +* IShft Intrinsic:: Logical bit shift. +* IShftC Intrinsic:: Circular bit shift. +@end ifset +@ifset familyF77 +* ISign Intrinsic:: Apply sign to magnitude (archaic). +@end ifset +@ifset familyF2U +* ITime Intrinsic:: Get local time of day. +@end ifset +@ifset familyVXT +* IZExt Intrinsic:: (Reserved for future use.) +* JIAbs Intrinsic:: (Reserved for future use.) +* JIAnd Intrinsic:: (Reserved for future use.) +* JIBClr Intrinsic:: (Reserved for future use.) +* JIBits Intrinsic:: (Reserved for future use.) +* JIBSet Intrinsic:: (Reserved for future use.) +* JIDiM Intrinsic:: (Reserved for future use.) +* JIDInt Intrinsic:: (Reserved for future use.) +* JIDNnt Intrinsic:: (Reserved for future use.) +* JIEOr Intrinsic:: (Reserved for future use.) +* JIFix Intrinsic:: (Reserved for future use.) +* JInt Intrinsic:: (Reserved for future use.) +* JIOr Intrinsic:: (Reserved for future use.) +* JIQint Intrinsic:: (Reserved for future use.) +* JIQNnt Intrinsic:: (Reserved for future use.) +* JIShft Intrinsic:: (Reserved for future use.) +* JIShftC Intrinsic:: (Reserved for future use.) +* JISign Intrinsic:: (Reserved for future use.) +* JMax0 Intrinsic:: (Reserved for future use.) +* JMax1 Intrinsic:: (Reserved for future use.) +* JMin0 Intrinsic:: (Reserved for future use.) +* JMin1 Intrinsic:: (Reserved for future use.) +* JMod Intrinsic:: (Reserved for future use.) +* JNInt Intrinsic:: (Reserved for future use.) +* JNot Intrinsic:: (Reserved for future use.) +* JZExt Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2U +* Kill Intrinsic (subroutine):: Signal a process. +@end ifset +@ifset familyBADU77 +* Kill Intrinsic (function):: Signal a process. +@end ifset +@ifset familyF90 +* Kind Intrinsic:: (Reserved for future use.) +* LBound Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* Len Intrinsic:: Length of character entity. +@end ifset +@ifset familyF90 +* Len_Trim Intrinsic:: Get last non-blank character in string. +@end ifset +@ifset familyF77 +* LGe Intrinsic:: Lexically greater than or equal. +* LGt Intrinsic:: Lexically greater than. +@end ifset +@ifset familyF2U +* Link Intrinsic (subroutine):: Make hard link in file system. +@end ifset +@ifset familyBADU77 +* Link Intrinsic (function):: Make hard link in file system. +@end ifset +@ifset familyF77 +* LLe Intrinsic:: Lexically less than or equal. +* LLt Intrinsic:: Lexically less than. +@end ifset +@ifset familyF2U +* LnBlnk Intrinsic:: Get last non-blank character in string. +* Loc Intrinsic:: Address of entity in core. +@end ifset +@ifset familyF77 +* Log Intrinsic:: Natural logarithm. +* Log10 Intrinsic:: Natural logarithm. +@end ifset +@ifset familyF90 +* Logical Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2U +* Long Intrinsic:: Conversion to @code{INTEGER(KIND=1)} (archaic). +@end ifset +@ifset familyF2C +* LShift Intrinsic:: Left-shift bits. +@end ifset +@ifset familyF2U +* LStat Intrinsic (subroutine):: Get file information. +* LStat Intrinsic (function):: Get file information. +* LTime Intrinsic:: Convert time to local time info. +@end ifset +@ifset familyF90 +* MatMul Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* Max Intrinsic:: Maximum value. +* Max0 Intrinsic:: Maximum value (archaic). +* Max1 Intrinsic:: Maximum value (archaic). +@end ifset +@ifset familyF90 +* MaxExponent Intrinsic:: (Reserved for future use.) +* MaxLoc Intrinsic:: (Reserved for future use.) +* MaxVal Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2U +* MClock Intrinsic:: Get number of clock ticks for process. +* MClock8 Intrinsic:: Get number of clock ticks for process. +@end ifset +@ifset familyF90 +* Merge Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* Min Intrinsic:: Minimum value. +* Min0 Intrinsic:: Minimum value (archaic). +* Min1 Intrinsic:: Minimum value (archaic). +@end ifset +@ifset familyF90 +* MinExponent Intrinsic:: (Reserved for future use.) +* MinLoc Intrinsic:: (Reserved for future use.) +* MinVal Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* Mod Intrinsic:: Remainder. +@end ifset +@ifset familyF90 +* Modulo Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyMIL +* MvBits Intrinsic:: Moving a bit field. +@end ifset +@ifset familyF90 +* Nearest Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* NInt Intrinsic:: Convert to @code{INTEGER} value rounded + to nearest whole number. +@end ifset +@ifset familyMIL +* Not Intrinsic:: Boolean NOT. +@end ifset +@ifset familyF2C +* Or Intrinsic:: Boolean OR. +@end ifset +@ifset familyF90 +* Pack Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2U +* PError Intrinsic:: Print error message for last error. +@end ifset +@ifset familyF90 +* Precision Intrinsic:: (Reserved for future use.) +* Present Intrinsic:: (Reserved for future use.) +* Product Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyVXT +* QAbs Intrinsic:: (Reserved for future use.) +* QACos Intrinsic:: (Reserved for future use.) +* QACosD Intrinsic:: (Reserved for future use.) +* QASin Intrinsic:: (Reserved for future use.) +* QASinD Intrinsic:: (Reserved for future use.) +* QATan Intrinsic:: (Reserved for future use.) +* QATan2 Intrinsic:: (Reserved for future use.) +* QATan2D Intrinsic:: (Reserved for future use.) +* QATanD Intrinsic:: (Reserved for future use.) +* QCos Intrinsic:: (Reserved for future use.) +* QCosD Intrinsic:: (Reserved for future use.) +* QCosH Intrinsic:: (Reserved for future use.) +* QDiM Intrinsic:: (Reserved for future use.) +* QExp Intrinsic:: (Reserved for future use.) +* QExt Intrinsic:: (Reserved for future use.) +* QExtD Intrinsic:: (Reserved for future use.) +* QFloat Intrinsic:: (Reserved for future use.) +* QInt Intrinsic:: (Reserved for future use.) +* QLog Intrinsic:: (Reserved for future use.) +* QLog10 Intrinsic:: (Reserved for future use.) +* QMax1 Intrinsic:: (Reserved for future use.) +* QMin1 Intrinsic:: (Reserved for future use.) +* QMod Intrinsic:: (Reserved for future use.) +* QNInt Intrinsic:: (Reserved for future use.) +* QSin Intrinsic:: (Reserved for future use.) +* QSinD Intrinsic:: (Reserved for future use.) +* QSinH Intrinsic:: (Reserved for future use.) +* QSqRt Intrinsic:: (Reserved for future use.) +* QTan Intrinsic:: (Reserved for future use.) +* QTanD Intrinsic:: (Reserved for future use.) +* QTanH Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF90 +* Radix Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2U +* Rand Intrinsic:: Random number. +@end ifset +@ifset familyF90 +* Random_Number Intrinsic:: (Reserved for future use.) +* Random_Seed Intrinsic:: (Reserved for future use.) +* Range Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* Real Intrinsic:: Convert value to type @code{REAL(KIND=1)}. +@end ifset +@ifset familyGNU +* RealPart Intrinsic:: Extract real part of complex. +@end ifset +@ifset familyF2U +* Rename Intrinsic (subroutine):: Rename file. +@end ifset +@ifset familyBADU77 +* Rename Intrinsic (function):: Rename file. +@end ifset +@ifset familyF90 +* Repeat Intrinsic:: (Reserved for future use.) +* Reshape Intrinsic:: (Reserved for future use.) +* RRSpacing Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2C +* RShift Intrinsic:: Right-shift bits. +@end ifset +@ifset familyF90 +* Scale Intrinsic:: (Reserved for future use.) +* Scan Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyVXT +* Secnds Intrinsic:: Get local time offset since midnight. +@end ifset +@ifset familyF2U +* Second Intrinsic (function):: Get CPU time for process in seconds. +* Second Intrinsic (subroutine):: Get CPU time for process + in seconds. +@end ifset +@ifset familyF90 +* Selected_Int_Kind Intrinsic:: (Reserved for future use.) +* Selected_Real_Kind Intrinsic:: (Reserved for future use.) +* Set_Exponent Intrinsic:: (Reserved for future use.) +* Shape Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2U +* Short Intrinsic:: Convert to @code{INTEGER(KIND=6)} value + truncated to whole number. +@end ifset +@ifset familyF77 +* Sign Intrinsic:: Apply sign to magnitude. +@end ifset +@ifset familyF2U +* Signal Intrinsic (subroutine):: Muck with signal handling. +@end ifset +@ifset familyBADU77 +* Signal Intrinsic (function):: Muck with signal handling. +@end ifset +@ifset familyF77 +* Sin Intrinsic:: Sine. +@end ifset +@ifset familyVXT +* SinD Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* SinH Intrinsic:: Hyperbolic sine. +@end ifset +@ifset familyF2U +* Sleep Intrinsic:: Sleep for a specified time. +@end ifset +@ifset familyF77 +* Sngl Intrinsic:: Convert (archaic). +@end ifset +@ifset familyVXT +* SnglQ Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF90 +* Spacing Intrinsic:: (Reserved for future use.) +* Spread Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* SqRt Intrinsic:: Square root. +@end ifset +@ifset familyF2U +* SRand Intrinsic:: Random seed. +* Stat Intrinsic (subroutine):: Get file information. +* Stat Intrinsic (function):: Get file information. +@end ifset +@ifset familyF90 +* Sum Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2U +* SymLnk Intrinsic (subroutine):: Make symbolic link in file system. +@end ifset +@ifset familyBADU77 +* SymLnk Intrinsic (function):: Make symbolic link in file system. +@end ifset +@ifset familyF2U +* System Intrinsic (subroutine):: Invoke shell (system) command. +@end ifset +@ifset familyBADU77 +* System Intrinsic (function):: Invoke shell (system) command. +@end ifset +@ifset familyF90 +* System_Clock Intrinsic:: Get current system clock value. +@end ifset +@ifset familyF77 +* Tan Intrinsic:: Tangent. +@end ifset +@ifset familyVXT +* TanD Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF77 +* TanH Intrinsic:: Hyperbolic tangent. +@end ifset +@ifset familyF2U +* Time Intrinsic (UNIX):: Get current time as time value. +@end ifset +@ifset familyVXT +* Time Intrinsic (VXT):: Get the time as a character value. +@end ifset +@ifset familyF2U +* Time8 Intrinsic:: Get current time as time value. +@end ifset +@ifset familyF90 +* Tiny Intrinsic:: (Reserved for future use.) +* Transfer Intrinsic:: (Reserved for future use.) +* Transpose Intrinsic:: (Reserved for future use.) +* Trim Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2U +* TtyNam Intrinsic (subroutine):: Get name of terminal device for unit. +* TtyNam Intrinsic (function):: Get name of terminal device for unit. +@end ifset +@ifset familyF90 +* UBound Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2U +* UMask Intrinsic (subroutine):: Set file creation permissions mask. +@end ifset +@ifset familyBADU77 +* UMask Intrinsic (function):: Set file creation permissions mask. +@end ifset +@ifset familyF2U +* Unlink Intrinsic (subroutine):: Unlink file. +@end ifset +@ifset familyBADU77 +* Unlink Intrinsic (function):: Unlink file. +@end ifset +@ifset familyF90 +* Unpack Intrinsic:: (Reserved for future use.) +* Verify Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2C +* XOr Intrinsic:: Boolean XOR. +* ZAbs Intrinsic:: Absolute value (archaic). +* ZCos Intrinsic:: Cosine (archaic). +* ZExp Intrinsic:: Exponential (archaic). +@end ifset +@ifset familyVXT +* ZExt Intrinsic:: (Reserved for future use.) +@end ifset +@ifset familyF2C +* ZLog Intrinsic:: Natural logarithm (archaic). +* ZSin Intrinsic:: Sine (archaic). +* ZSqRt Intrinsic:: Square root (archaic). +@end ifset +@end menu + +@ifset familyF2U +@node Abort Intrinsic +@subsubsection Abort Intrinsic +@cindex Abort intrinsic +@cindex intrinsics, Abort + +@noindent +@example +CALL Abort() +@end example + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Prints a message and potentially causes a core dump via @code{abort(3)}. + +@end ifset +@ifset familyF77 +@node Abs Intrinsic +@subsubsection Abs Intrinsic +@cindex Abs intrinsic +@cindex intrinsics, Abs + +@noindent +@example +Abs(@var{A}) +@end example + +@noindent +Abs: @code{INTEGER} or @code{REAL} function. +The exact type depends on that of argument @var{A}---if @var{A} is +@code{COMPLEX}, this function's type is @code{REAL} +with the same @samp{KIND=} value as the type of @var{A}. +Otherwise, this function's type is the same as that of @var{A}. + +@noindent +@var{A}: @code{INTEGER}, @code{REAL}, or @code{COMPLEX}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the absolute value of @var{A}. + +If @var{A} is type @code{COMPLEX}, the absolute +value is computed as: + +@example +SQRT(REALPART(@var{A})**2, IMAGPART(@var{A})**2) +@end example + +@noindent +Otherwise, it is computed by negating the @var{A} if +it is negative, or returning @var{A}. + +@xref{Sign Intrinsic}, for how to explicitly +compute the positive or negative form of the absolute +value of an expression. + +@end ifset +@ifset familyF2U +@node Access Intrinsic +@subsubsection Access Intrinsic +@cindex Access intrinsic +@cindex intrinsics, Access + +@noindent +@example +Access(@var{Name}, @var{Mode}) +@end example + +@noindent +Access: @code{INTEGER(KIND=1)} function. + +@noindent +@var{Name}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Mode}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Checks file @var{Name} for accessibility in the mode specified by @var{Mode} and +returns 0 if the file is accessible in that mode, otherwise an error +code if the file is inaccessible or @var{Mode} is invalid. +See @code{access(2)}. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{Name}---otherwise, +trailing blanks in @var{Name} are ignored. +@var{Mode} may be a concatenation of any of the following characters: + +@table @samp +@item r +Read permission + +@item w +Write permission + +@item x +Execute permission + +@item @kbd{SPC} +Existence +@end table + +@end ifset +@ifset familyASC +@node AChar Intrinsic +@subsubsection AChar Intrinsic +@cindex AChar intrinsic +@cindex intrinsics, AChar + +@noindent +@example +AChar(@var{I}) +@end example + +@noindent +AChar: @code{CHARACTER*1} function. + +@noindent +@var{I}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}, @code{f90}. + +@noindent +Description: + +Returns the ASCII character corresponding to the +code specified by @var{I}. + +@xref{IAChar Intrinsic}, for the inverse of this function. + +@xref{Char Intrinsic}, for the function corresponding +to the system's native character set. + +@end ifset +@ifset familyF77 +@node ACos Intrinsic +@subsubsection ACos Intrinsic +@cindex ACos intrinsic +@cindex intrinsics, ACos + +@noindent +@example +ACos(@var{X}) +@end example + +@noindent +ACos: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the arc-cosine (inverse cosine) of @var{X} +in radians. + +@xref{Cos Intrinsic}, for the inverse of this function. + +@end ifset +@ifset familyVXT +@node ACosD Intrinsic +@subsubsection ACosD Intrinsic +@cindex ACosD intrinsic +@cindex intrinsics, ACosD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL ACosD} to use this name for an +external procedure. + +@end ifset +@ifset familyF90 +@node AdjustL Intrinsic +@subsubsection AdjustL Intrinsic +@cindex AdjustL intrinsic +@cindex intrinsics, AdjustL + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL AdjustL} to use this name for an +external procedure. + +@node AdjustR Intrinsic +@subsubsection AdjustR Intrinsic +@cindex AdjustR intrinsic +@cindex intrinsics, AdjustR + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL AdjustR} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node AImag Intrinsic +@subsubsection AImag Intrinsic +@cindex AImag intrinsic +@cindex intrinsics, AImag + +@noindent +@example +AImag(@var{Z}) +@end example + +@noindent +AImag: @code{REAL} function. +This intrinsic is valid when argument @var{Z} is +@code{COMPLEX(KIND=1)}. +When @var{Z} is any other @code{COMPLEX} type, +this intrinsic is valid only when used as the argument to +@code{REAL()}, as explained below. + +@noindent +@var{Z}: @code{COMPLEX}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the (possibly converted) imaginary part of @var{Z}. + +Use of @code{AIMAG()} with an argument of a type +other than @code{COMPLEX(KIND=1)} is restricted to the following case: + +@example +REAL(AIMAG(Z)) +@end example + +@noindent +This expression converts the imaginary part of Z to +@code{REAL(KIND=1)}. + +@xref{REAL() and AIMAG() of Complex}, for more information. + +@end ifset +@ifset familyVXT +@node AIMax0 Intrinsic +@subsubsection AIMax0 Intrinsic +@cindex AIMax0 intrinsic +@cindex intrinsics, AIMax0 + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL AIMax0} to use this name for an +external procedure. + +@node AIMin0 Intrinsic +@subsubsection AIMin0 Intrinsic +@cindex AIMin0 intrinsic +@cindex intrinsics, AIMin0 + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL AIMin0} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node AInt Intrinsic +@subsubsection AInt Intrinsic +@cindex AInt intrinsic +@cindex intrinsics, AInt + +@noindent +@example +AInt(@var{A}) +@end example + +@noindent +AInt: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{A}. + +@noindent +@var{A}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns @var{A} with the fractional portion of its +magnitude truncated and its sign preserved. +(Also called ``truncation towards zero''.) + +@xref{ANInt Intrinsic}, for how to round to nearest +whole number. + +@xref{Int Intrinsic}, for how to truncate and then convert +number to @code{INTEGER}. + +@end ifset +@ifset familyVXT +@node AJMax0 Intrinsic +@subsubsection AJMax0 Intrinsic +@cindex AJMax0 intrinsic +@cindex intrinsics, AJMax0 + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL AJMax0} to use this name for an +external procedure. + +@node AJMin0 Intrinsic +@subsubsection AJMin0 Intrinsic +@cindex AJMin0 intrinsic +@cindex intrinsics, AJMin0 + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL AJMin0} to use this name for an +external procedure. + +@end ifset +@ifset familyF2U +@node Alarm Intrinsic +@subsubsection Alarm Intrinsic +@cindex Alarm intrinsic +@cindex intrinsics, Alarm + +@noindent +@example +CALL Alarm(@var{Seconds}, @var{Handler}, @var{Status}) +@end example + +@noindent +@var{Seconds}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Handler}: Signal handler (@code{INTEGER FUNCTION} or @code{SUBROUTINE}) +or dummy/global @code{INTEGER(KIND=1)} scalar. + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@end ifset +@ifset familyF90 +@node All Intrinsic +@subsubsection All Intrinsic +@cindex All intrinsic +@cindex intrinsics, All + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL All} to use this name for an +external procedure. + +@node Allocated Intrinsic +@subsubsection Allocated Intrinsic +@cindex Allocated intrinsic +@cindex intrinsics, Allocated + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Allocated} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node ALog Intrinsic +@subsubsection ALog Intrinsic +@cindex ALog intrinsic +@cindex intrinsics, ALog + +@noindent +@example +ALog(@var{X}) +@end example + +@noindent +ALog: @code{REAL(KIND=1)} function. + +@noindent +@var{X}: @code{REAL(KIND=1)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{LOG()} that is specific +to one type for @var{X}. +@xref{Log Intrinsic}. + +@node ALog10 Intrinsic +@subsubsection ALog10 Intrinsic +@cindex ALog10 intrinsic +@cindex intrinsics, ALog10 + +@noindent +@example +ALog10(@var{X}) +@end example + +@noindent +ALog10: @code{REAL(KIND=1)} function. + +@noindent +@var{X}: @code{REAL(KIND=1)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{LOG10()} that is specific +to one type for @var{X}. +@xref{Log10 Intrinsic}. + +@node AMax0 Intrinsic +@subsubsection AMax0 Intrinsic +@cindex AMax0 intrinsic +@cindex intrinsics, AMax0 + +@noindent +@example +AMax0(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n) +@end example + +@noindent +AMax0: @code{REAL(KIND=1)} function. + +@noindent +@var{A}: @code{INTEGER(KIND=1)}; at least two such arguments must be provided; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{MAX()} that is specific +to one type for @var{A} and a different return type. +@xref{Max Intrinsic}. + +@node AMax1 Intrinsic +@subsubsection AMax1 Intrinsic +@cindex AMax1 intrinsic +@cindex intrinsics, AMax1 + +@noindent +@example +AMax1(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n) +@end example + +@noindent +AMax1: @code{REAL(KIND=1)} function. + +@noindent +@var{A}: @code{REAL(KIND=1)}; at least two such arguments must be provided; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{MAX()} that is specific +to one type for @var{A}. +@xref{Max Intrinsic}. + +@node AMin0 Intrinsic +@subsubsection AMin0 Intrinsic +@cindex AMin0 intrinsic +@cindex intrinsics, AMin0 + +@noindent +@example +AMin0(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n) +@end example + +@noindent +AMin0: @code{REAL(KIND=1)} function. + +@noindent +@var{A}: @code{INTEGER(KIND=1)}; at least two such arguments must be provided; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{MIN()} that is specific +to one type for @var{A} and a different return type. +@xref{Min Intrinsic}. + +@node AMin1 Intrinsic +@subsubsection AMin1 Intrinsic +@cindex AMin1 intrinsic +@cindex intrinsics, AMin1 + +@noindent +@example +AMin1(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n) +@end example + +@noindent +AMin1: @code{REAL(KIND=1)} function. + +@noindent +@var{A}: @code{REAL(KIND=1)}; at least two such arguments must be provided; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{MIN()} that is specific +to one type for @var{A}. +@xref{Min Intrinsic}. + +@node AMod Intrinsic +@subsubsection AMod Intrinsic +@cindex AMod intrinsic +@cindex intrinsics, AMod + +@noindent +@example +AMod(@var{A}, @var{P}) +@end example + +@noindent +AMod: @code{REAL(KIND=1)} function. + +@noindent +@var{A}: @code{REAL(KIND=1)}; scalar; INTENT(IN). + +@noindent +@var{P}: @code{REAL(KIND=1)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{MOD()} that is specific +to one type for @var{A}. +@xref{Mod Intrinsic}. + +@end ifset +@ifset familyF2C +@node And Intrinsic +@subsubsection And Intrinsic +@cindex And intrinsic +@cindex intrinsics, And + +@noindent +@example +And(@var{I}, @var{J}) +@end example + +@noindent +And: @code{INTEGER} or @code{LOGICAL} function, the exact type being the result of cross-promoting the +types of all the arguments. + +@noindent +@var{I}: @code{INTEGER} or @code{LOGICAL}; scalar; INTENT(IN). + +@noindent +@var{J}: @code{INTEGER} or @code{LOGICAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}. + +@noindent +Description: + +Returns value resulting from boolean AND of +pair of bits in each of @var{I} and @var{J}. + +@end ifset +@ifset familyF77 +@node ANInt Intrinsic +@subsubsection ANInt Intrinsic +@cindex ANInt intrinsic +@cindex intrinsics, ANInt + +@noindent +@example +ANInt(@var{A}) +@end example + +@noindent +ANInt: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{A}. + +@noindent +@var{A}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns @var{A} with the fractional portion of its +magnitude eliminated by rounding to the nearest whole +number and with its sign preserved. + +A fractional portion exactly equal to +@samp{.5} is rounded to the whole number that +is larger in magnitude. +(Also called ``Fortran round''.) + +@xref{AInt Intrinsic}, for how to truncate to +whole number. + +@xref{NInt Intrinsic}, for how to round and then convert +number to @code{INTEGER}. + +@end ifset +@ifset familyF90 +@node Any Intrinsic +@subsubsection Any Intrinsic +@cindex Any intrinsic +@cindex intrinsics, Any + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Any} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node ASin Intrinsic +@subsubsection ASin Intrinsic +@cindex ASin intrinsic +@cindex intrinsics, ASin + +@noindent +@example +ASin(@var{X}) +@end example + +@noindent +ASin: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the arc-sine (inverse sine) of @var{X} +in radians. + +@xref{Sin Intrinsic}, for the inverse of this function. + +@end ifset +@ifset familyVXT +@node ASinD Intrinsic +@subsubsection ASinD Intrinsic +@cindex ASinD intrinsic +@cindex intrinsics, ASinD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL ASinD} to use this name for an +external procedure. + +@end ifset +@ifset familyF90 +@node Associated Intrinsic +@subsubsection Associated Intrinsic +@cindex Associated intrinsic +@cindex intrinsics, Associated + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Associated} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node ATan Intrinsic +@subsubsection ATan Intrinsic +@cindex ATan intrinsic +@cindex intrinsics, ATan + +@noindent +@example +ATan(@var{X}) +@end example + +@noindent +ATan: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the arc-tangent (inverse tangent) of @var{X} +in radians. + +@xref{Tan Intrinsic}, for the inverse of this function. + +@node ATan2 Intrinsic +@subsubsection ATan2 Intrinsic +@cindex ATan2 intrinsic +@cindex intrinsics, ATan2 + +@noindent +@example +ATan2(@var{Y}, @var{X}) +@end example + +@noindent +ATan2: @code{REAL} function, the exact type being the result of cross-promoting the +types of all the arguments. + +@noindent +@var{Y}: @code{REAL}; scalar; INTENT(IN). + +@noindent +@var{X}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the arc-tangent (inverse tangent) of the complex +number (@var{Y}, @var{X}) in radians. + +@xref{Tan Intrinsic}, for the inverse of this function. + +@end ifset +@ifset familyVXT +@node ATan2D Intrinsic +@subsubsection ATan2D Intrinsic +@cindex ATan2D intrinsic +@cindex intrinsics, ATan2D + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL ATan2D} to use this name for an +external procedure. + +@node ATanD Intrinsic +@subsubsection ATanD Intrinsic +@cindex ATanD intrinsic +@cindex intrinsics, ATanD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL ATanD} to use this name for an +external procedure. + +@end ifset +@ifset familyF2U +@node BesJ0 Intrinsic +@subsubsection BesJ0 Intrinsic +@cindex BesJ0 intrinsic +@cindex intrinsics, BesJ0 + +@noindent +@example +BesJ0(@var{X}) +@end example + +@noindent +BesJ0: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Calculates the Bessel function of the first kind of order 0 of @var{X}. +See @code{bessel(3m)}, on whose implementation the function depends. +@node BesJ1 Intrinsic +@subsubsection BesJ1 Intrinsic +@cindex BesJ1 intrinsic +@cindex intrinsics, BesJ1 + +@noindent +@example +BesJ1(@var{X}) +@end example + +@noindent +BesJ1: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Calculates the Bessel function of the first kind of order 1 of @var{X}. +See @code{bessel(3m)}, on whose implementation the function depends. +@node BesJN Intrinsic +@subsubsection BesJN Intrinsic +@cindex BesJN intrinsic +@cindex intrinsics, BesJN + +@noindent +@example +BesJN(@var{N}, @var{X}) +@end example + +@noindent +BesJN: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}. + +@noindent +@var{N}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{X}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Calculates the Bessel function of the first kind of order @var{N} of @var{X}. +See @code{bessel(3m)}, on whose implementation the function depends. +@node BesY0 Intrinsic +@subsubsection BesY0 Intrinsic +@cindex BesY0 intrinsic +@cindex intrinsics, BesY0 + +@noindent +@example +BesY0(@var{X}) +@end example + +@noindent +BesY0: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Calculates the Bessel function of the second kind of order 0 of @var{X}. +See @code{bessel(3m)}, on whose implementation the function depends. +@node BesY1 Intrinsic +@subsubsection BesY1 Intrinsic +@cindex BesY1 intrinsic +@cindex intrinsics, BesY1 + +@noindent +@example +BesY1(@var{X}) +@end example + +@noindent +BesY1: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Calculates the Bessel function of the second kind of order 1 of @var{X}. +See @code{bessel(3m)}, on whose implementation the function depends. +@node BesYN Intrinsic +@subsubsection BesYN Intrinsic +@cindex BesYN intrinsic +@cindex intrinsics, BesYN + +@noindent +@example +BesYN(@var{N}, @var{X}) +@end example + +@noindent +BesYN: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}. + +@noindent +@var{N}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{X}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Calculates the Bessel function of the second kind of order @var{N} of @var{X}. +See @code{bessel(3m)}, on whose implementation the function depends. +@end ifset +@ifset familyVXT +@node BITest Intrinsic +@subsubsection BITest Intrinsic +@cindex BITest intrinsic +@cindex intrinsics, BITest + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL BITest} to use this name for an +external procedure. + +@end ifset +@ifset familyF90 +@node Bit_Size Intrinsic +@subsubsection Bit_Size Intrinsic +@cindex Bit_Size intrinsic +@cindex intrinsics, Bit_Size + +@noindent +@example +Bit_Size(@var{I}) +@end example + +@noindent +Bit_Size: @code{INTEGER} function, the @samp{KIND=} value of the type being that of argument @var{I}. + +@noindent +@var{I}: @code{INTEGER}; scalar. + +@noindent +Intrinsic groups: @code{f90}. + +@noindent +Description: + +Returns the number of bits (integer precision plus sign bit) +represented by the type for @var{I}. + +@xref{BTest Intrinsic}, for how to test the value of a +bit in a variable or array. + +@xref{IBSet Intrinsic}, for how to set a bit in a variable to 1. + +@xref{IBClr Intrinsic}, for how to set a bit in a variable to 0. + + +@end ifset +@ifset familyVXT +@node BJTest Intrinsic +@subsubsection BJTest Intrinsic +@cindex BJTest intrinsic +@cindex intrinsics, BJTest + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL BJTest} to use this name for an +external procedure. + +@end ifset +@ifset familyMIL +@node BTest Intrinsic +@subsubsection BTest Intrinsic +@cindex BTest intrinsic +@cindex intrinsics, BTest + +@noindent +@example +BTest(@var{I}, @var{Pos}) +@end example + +@noindent +BTest: @code{LOGICAL(KIND=1)} function. + +@noindent +@var{I}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Pos}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}. + +@noindent +Description: + +Returns @code{.TRUE.} if bit @var{Pos} in @var{I} is +1, @code{.FALSE.} otherwise. + +(Bit 0 is the low-order (rightmost) bit, adding the value +@ifinfo +2**0, +@end ifinfo +@iftex +@tex +$2^0$, +@end tex +@end iftex +or 1, +to the number if set to 1; +bit 1 is the next-higher-order bit, adding +@ifinfo +2**1, +@end ifinfo +@iftex +@tex +$2^1$, +@end tex +@end iftex +or 2; +bit 2 adds +@ifinfo +2**2, +@end ifinfo +@iftex +@tex +$2^2$, +@end tex +@end iftex +or 4; and so on.) + +@xref{Bit_Size Intrinsic}, for how to obtain the number of bits +in a type. +The leftmost bit of @var{I} is @samp{BIT_SIZE(@var{I}-1}. + +@end ifset +@ifset familyF77 +@node CAbs Intrinsic +@subsubsection CAbs Intrinsic +@cindex CAbs intrinsic +@cindex intrinsics, CAbs + +@noindent +@example +CAbs(@var{A}) +@end example + +@noindent +CAbs: @code{REAL(KIND=1)} function. + +@noindent +@var{A}: @code{COMPLEX(KIND=1)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{ABS()} that is specific +to one type for @var{A}. +@xref{Abs Intrinsic}. + +@node CCos Intrinsic +@subsubsection CCos Intrinsic +@cindex CCos intrinsic +@cindex intrinsics, CCos + +@noindent +@example +CCos(@var{X}) +@end example + +@noindent +CCos: @code{COMPLEX(KIND=1)} function. + +@noindent +@var{X}: @code{COMPLEX(KIND=1)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{COS()} that is specific +to one type for @var{X}. +@xref{Cos Intrinsic}. + +@end ifset +@ifset familyFVZ +@node CDAbs Intrinsic +@subsubsection CDAbs Intrinsic +@cindex CDAbs intrinsic +@cindex intrinsics, CDAbs + +@noindent +@example +CDAbs(@var{A}) +@end example + +@noindent +CDAbs: @code{REAL(KIND=2)} function. + +@noindent +@var{A}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}, @code{vxt}. + +@noindent +Description: + +Archaic form of @code{ABS()} that is specific +to one type for @var{A}. +@xref{Abs Intrinsic}. + +@node CDCos Intrinsic +@subsubsection CDCos Intrinsic +@cindex CDCos intrinsic +@cindex intrinsics, CDCos + +@noindent +@example +CDCos(@var{X}) +@end example + +@noindent +CDCos: @code{COMPLEX(KIND=2)} function. + +@noindent +@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}, @code{vxt}. + +@noindent +Description: + +Archaic form of @code{COS()} that is specific +to one type for @var{X}. +@xref{Cos Intrinsic}. + +@node CDExp Intrinsic +@subsubsection CDExp Intrinsic +@cindex CDExp intrinsic +@cindex intrinsics, CDExp + +@noindent +@example +CDExp(@var{X}) +@end example + +@noindent +CDExp: @code{COMPLEX(KIND=2)} function. + +@noindent +@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}, @code{vxt}. + +@noindent +Description: + +Archaic form of @code{EXP()} that is specific +to one type for @var{X}. +@xref{Exp Intrinsic}. + +@node CDLog Intrinsic +@subsubsection CDLog Intrinsic +@cindex CDLog intrinsic +@cindex intrinsics, CDLog + +@noindent +@example +CDLog(@var{X}) +@end example + +@noindent +CDLog: @code{COMPLEX(KIND=2)} function. + +@noindent +@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}, @code{vxt}. + +@noindent +Description: + +Archaic form of @code{LOG()} that is specific +to one type for @var{X}. +@xref{Log Intrinsic}. + +@node CDSin Intrinsic +@subsubsection CDSin Intrinsic +@cindex CDSin intrinsic +@cindex intrinsics, CDSin + +@noindent +@example +CDSin(@var{X}) +@end example + +@noindent +CDSin: @code{COMPLEX(KIND=2)} function. + +@noindent +@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}, @code{vxt}. + +@noindent +Description: + +Archaic form of @code{SIN()} that is specific +to one type for @var{X}. +@xref{Sin Intrinsic}. + +@node CDSqRt Intrinsic +@subsubsection CDSqRt Intrinsic +@cindex CDSqRt intrinsic +@cindex intrinsics, CDSqRt + +@noindent +@example +CDSqRt(@var{X}) +@end example + +@noindent +CDSqRt: @code{COMPLEX(KIND=2)} function. + +@noindent +@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}, @code{vxt}. + +@noindent +Description: + +Archaic form of @code{SQRT()} that is specific +to one type for @var{X}. +@xref{SqRt Intrinsic}. + +@end ifset +@ifset familyF90 +@node Ceiling Intrinsic +@subsubsection Ceiling Intrinsic +@cindex Ceiling intrinsic +@cindex intrinsics, Ceiling + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Ceiling} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node CExp Intrinsic +@subsubsection CExp Intrinsic +@cindex CExp intrinsic +@cindex intrinsics, CExp + +@noindent +@example +CExp(@var{X}) +@end example + +@noindent +CExp: @code{COMPLEX(KIND=1)} function. + +@noindent +@var{X}: @code{COMPLEX(KIND=1)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{EXP()} that is specific +to one type for @var{X}. +@xref{Exp Intrinsic}. + +@node Char Intrinsic +@subsubsection Char Intrinsic +@cindex Char intrinsic +@cindex intrinsics, Char + +@noindent +@example +Char(@var{I}) +@end example + +@noindent +Char: @code{CHARACTER*1} function. + +@noindent +@var{I}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the character corresponding to the +code specified by @var{I}, using the system's +native character set. + +Because the system's native character set is used, +the correspondence between character and their codes +is not necessarily the same between GNU Fortran +implementations. + +Note that no intrinsic exists to convert a numerical +value to a printable character string. +For example, there is no intrinsic that, given +an @code{INTEGER} or @code{REAL} argument with the +value @samp{154}, returns the @code{CHARACTER} +result @samp{'154'}. + +Instead, you can use internal-file I/O to do this kind +of conversion. +For example: + +@smallexample +INTEGER VALUE +CHARACTER*10 STRING +VALUE = 154 +WRITE (STRING, '(I10)'), VALUE +PRINT *, STRING +END +@end smallexample + +The above program, when run, prints: + +@smallexample + 154 +@end smallexample + +@xref{IChar Intrinsic}, for the inverse of the @code{CHAR} function. + +@xref{AChar Intrinsic}, for the function corresponding +to the ASCII character set. + +@end ifset +@ifset familyF2U +@node ChDir Intrinsic (subroutine) +@subsubsection ChDir Intrinsic (subroutine) +@cindex ChDir intrinsic +@cindex intrinsics, ChDir + +@noindent +@example +CALL ChDir(@var{Dir}, @var{Status}) +@end example + +@noindent +@var{Dir}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Sets the current working directory to be @var{Dir}. +If the @var{Status} argument is supplied, it contains 0 +on success or a non-zero error code otherwise upon return. +See @code{chdir(3)}. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{Status} argument. + +For information on other intrinsics with the same name: +@xref{ChDir Intrinsic (function)}. + +@end ifset +@ifset familyBADU77 +@node ChDir Intrinsic (function) +@subsubsection ChDir Intrinsic (function) +@cindex ChDir intrinsic +@cindex intrinsics, ChDir + +@noindent +@example +ChDir(@var{Dir}) +@end example + +@noindent +ChDir: @code{INTEGER(KIND=1)} function. + +@noindent +@var{Dir}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{badu77}. + +@noindent +Description: + +Sets the current working directory to be @var{Dir}. +Returns 0 on success or a non-zero error code. +See @code{chdir(3)}. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. + +For information on other intrinsics with the same name: +@xref{ChDir Intrinsic (subroutine)}. + +@end ifset +@ifset familyF2U +@node ChMod Intrinsic (subroutine) +@subsubsection ChMod Intrinsic (subroutine) +@cindex ChMod intrinsic +@cindex intrinsics, ChMod + +@noindent +@example +CALL ChMod(@var{Name}, @var{Mode}, @var{Status}) +@end example + +@noindent +@var{Name}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Mode}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Changes the access mode of file @var{Name} according to the +specification @var{Mode}, which is given in the format of +@code{chmod(1)}. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{Name}---otherwise, +trailing blanks in @var{Name} are ignored. +Currently, @var{Name} must not contain the single quote +character. + +If the @var{Status} argument is supplied, it contains +0 on success or a non-zero error code upon return. + +Note that this currently works +by actually invoking @code{/bin/chmod} (or the @code{chmod} found when +the library was configured) and so may fail in some circumstances and +will, anyway, be slow. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{Status} argument. + +For information on other intrinsics with the same name: +@xref{ChMod Intrinsic (function)}. + +@end ifset +@ifset familyBADU77 +@node ChMod Intrinsic (function) +@subsubsection ChMod Intrinsic (function) +@cindex ChMod intrinsic +@cindex intrinsics, ChMod + +@noindent +@example +ChMod(@var{Name}, @var{Mode}) +@end example + +@noindent +ChMod: @code{INTEGER(KIND=1)} function. + +@noindent +@var{Name}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Mode}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{badu77}. + +@noindent +Description: + +Changes the access mode of file @var{Name} according to the +specification @var{Mode}, which is given in the format of +@code{chmod(1)}. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{Name}---otherwise, +trailing blanks in @var{Name} are ignored. +Currently, @var{Name} must not contain the single quote +character. + +Returns 0 on success or a non-zero error code otherwise. + +Note that this currently works +by actually invoking @code{/bin/chmod} (or the @code{chmod} found when +the library was configured) and so may fail in some circumstances and +will, anyway, be slow. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. + +For information on other intrinsics with the same name: +@xref{ChMod Intrinsic (subroutine)}. + +@end ifset +@ifset familyF77 +@node CLog Intrinsic +@subsubsection CLog Intrinsic +@cindex CLog intrinsic +@cindex intrinsics, CLog + +@noindent +@example +CLog(@var{X}) +@end example + +@noindent +CLog: @code{COMPLEX(KIND=1)} function. + +@noindent +@var{X}: @code{COMPLEX(KIND=1)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{LOG()} that is specific +to one type for @var{X}. +@xref{Log Intrinsic}. + +@node Cmplx Intrinsic +@subsubsection Cmplx Intrinsic +@cindex Cmplx intrinsic +@cindex intrinsics, Cmplx + +@noindent +@example +Cmplx(@var{X}, @var{Y}) +@end example + +@noindent +Cmplx: @code{COMPLEX(KIND=1)} function. + +@noindent +@var{X}: @code{INTEGER}, @code{REAL}, or @code{COMPLEX}; scalar; INTENT(IN). + +@noindent +@var{Y}: @code{INTEGER} or @code{REAL}; OPTIONAL (must be omitted if @var{X} is @code{COMPLEX}); scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +If @var{X} is not type @code{COMPLEX}, +constructs a value of type @code{COMPLEX(KIND=1)} from the +real and imaginary values specified by @var{X} and +@var{Y}, respectively. +If @var{Y} is omitted, @samp{0.} is assumed. + +If @var{X} is type @code{COMPLEX}, +converts it to type @code{COMPLEX(KIND=1)}. + +@xref{Complex Intrinsic}, for information on easily constructing +a @code{COMPLEX} value of arbitrary precision from @code{REAL} +arguments. + +@end ifset +@ifset familyGNU +@node Complex Intrinsic +@subsubsection Complex Intrinsic +@cindex Complex intrinsic +@cindex intrinsics, Complex + +@noindent +@example +Complex(@var{Real}, @var{Imag}) +@end example + +@noindent +Complex: @code{COMPLEX} function, the exact type being the result of cross-promoting the +types of all the arguments. + +@noindent +@var{Real}: @code{INTEGER} or @code{REAL}; scalar; INTENT(IN). + +@noindent +@var{Imag}: @code{INTEGER} or @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{gnu}. + +@noindent +Description: + +Returns a @code{COMPLEX} value that has @samp{Real} and @samp{Imag} as its +real and imaginary parts, respectively. + +If @var{Real} and @var{Imag} are the same type, and that type is not +@code{INTEGER}, no data conversion is performed, and the type of +the resulting value has the same kind value as the types +of @var{Real} and @var{Imag}. + +If @var{Real} and @var{Imag} are not the same type, the usual type-promotion +rules are applied to both, converting either or both to the +appropriate @code{REAL} type. +The type of the resulting value has the same kind value as the +type to which both @var{Real} and @var{Imag} were converted, in this case. + +If @var{Real} and @var{Imag} are both @code{INTEGER}, they are both converted +to @code{REAL(KIND=1)}, and the result of the @code{COMPLEX()} +invocation is type @code{COMPLEX(KIND=1)}. + +@emph{Note:} The way to do this in standard Fortran 90 +is too hairy to describe here, but it is important to +note that @samp{CMPLX(D1,D2)} returns a @code{COMPLEX(KIND=1)} +result even if @samp{D1} and @samp{D2} are type @code{REAL(KIND=2)}. +Hence the availability of @code{COMPLEX()} in GNU Fortran. + +@end ifset +@ifset familyF77 +@node Conjg Intrinsic +@subsubsection Conjg Intrinsic +@cindex Conjg intrinsic +@cindex intrinsics, Conjg + +@noindent +@example +Conjg(@var{Z}) +@end example + +@noindent +Conjg: @code{COMPLEX} function, the @samp{KIND=} value of the type being that of argument @var{Z}. + +@noindent +@var{Z}: @code{COMPLEX}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the complex conjugate: + +@example +COMPLEX(REALPART(@var{Z}), -IMAGPART(@var{Z})) +@end example + +@node Cos Intrinsic +@subsubsection Cos Intrinsic +@cindex Cos intrinsic +@cindex intrinsics, Cos + +@noindent +@example +Cos(@var{X}) +@end example + +@noindent +Cos: @code{REAL} or @code{COMPLEX} function, the exact type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL} or @code{COMPLEX}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the cosine of @var{X}, an angle measured +in radians. + +@xref{ACos Intrinsic}, for the inverse of this function. + +@end ifset +@ifset familyVXT +@node CosD Intrinsic +@subsubsection CosD Intrinsic +@cindex CosD intrinsic +@cindex intrinsics, CosD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL CosD} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node CosH Intrinsic +@subsubsection CosH Intrinsic +@cindex CosH intrinsic +@cindex intrinsics, CosH + +@noindent +@example +CosH(@var{X}) +@end example + +@noindent +CosH: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the hyperbolic cosine of @var{X}. + +@end ifset +@ifset familyF90 +@node Count Intrinsic +@subsubsection Count Intrinsic +@cindex Count intrinsic +@cindex intrinsics, Count + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Count} to use this name for an +external procedure. + +@node Cpu_Time Intrinsic +@subsubsection Cpu_Time Intrinsic +@cindex Cpu_Time intrinsic +@cindex intrinsics, Cpu_Time + +@noindent +@example +CALL Cpu_Time(@var{Seconds}) +@end example + +@noindent +@var{Seconds}: @code{REAL(KIND=1)}; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{f90}. + +@noindent +Description: + +Returns in @var{Seconds} the current value of the system time. +This implementation of the Fortran 95 intrinsic is just an alias for +@code{second} @xref{Second Intrinsic (subroutine)}. + +@node CShift Intrinsic +@subsubsection CShift Intrinsic +@cindex CShift intrinsic +@cindex intrinsics, CShift + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL CShift} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node CSin Intrinsic +@subsubsection CSin Intrinsic +@cindex CSin intrinsic +@cindex intrinsics, CSin + +@noindent +@example +CSin(@var{X}) +@end example + +@noindent +CSin: @code{COMPLEX(KIND=1)} function. + +@noindent +@var{X}: @code{COMPLEX(KIND=1)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{SIN()} that is specific +to one type for @var{X}. +@xref{Sin Intrinsic}. + +@node CSqRt Intrinsic +@subsubsection CSqRt Intrinsic +@cindex CSqRt intrinsic +@cindex intrinsics, CSqRt + +@noindent +@example +CSqRt(@var{X}) +@end example + +@noindent +CSqRt: @code{COMPLEX(KIND=1)} function. + +@noindent +@var{X}: @code{COMPLEX(KIND=1)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{SQRT()} that is specific +to one type for @var{X}. +@xref{SqRt Intrinsic}. + +@end ifset +@ifset familyF2U +@node CTime Intrinsic (subroutine) +@subsubsection CTime Intrinsic (subroutine) +@cindex CTime intrinsic +@cindex intrinsics, CTime + +@noindent +@example +CALL CTime(@var{Result}, @var{STime}) +@end example + +@noindent +@var{Result}: @code{CHARACTER}; scalar; INTENT(OUT). + +@noindent +@var{STime}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Converts @var{STime}, a system time value, such as returned by +@code{TIME8()}, to a string of the form @samp{Sat Aug 19 18:13:14 1995}, +and returns that string in @var{Result}. + +@xref{Time8 Intrinsic}. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine. + +For information on other intrinsics with the same name: +@xref{CTime Intrinsic (function)}. + +@node CTime Intrinsic (function) +@subsubsection CTime Intrinsic (function) +@cindex CTime intrinsic +@cindex intrinsics, CTime + +@noindent +@example +CTime(@var{STime}) +@end example + +@noindent +CTime: @code{CHARACTER*(*)} function. + +@noindent +@var{STime}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Converts @var{STime}, a system time value, such as returned by +@code{TIME8()}, to a string of the form @samp{Sat Aug 19 18:13:14 1995}, +and returns that string as the function value. + +@xref{Time8 Intrinsic}. + +For information on other intrinsics with the same name: +@xref{CTime Intrinsic (subroutine)}. + +@end ifset +@ifset familyF77 +@node DAbs Intrinsic +@subsubsection DAbs Intrinsic +@cindex DAbs intrinsic +@cindex intrinsics, DAbs + +@noindent +@example +DAbs(@var{A}) +@end example + +@noindent +DAbs: @code{REAL(KIND=2)} function. + +@noindent +@var{A}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{ABS()} that is specific +to one type for @var{A}. +@xref{Abs Intrinsic}. + +@node DACos Intrinsic +@subsubsection DACos Intrinsic +@cindex DACos intrinsic +@cindex intrinsics, DACos + +@noindent +@example +DACos(@var{X}) +@end example + +@noindent +DACos: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{ACOS()} that is specific +to one type for @var{X}. +@xref{ACos Intrinsic}. + +@end ifset +@ifset familyVXT +@node DACosD Intrinsic +@subsubsection DACosD Intrinsic +@cindex DACosD intrinsic +@cindex intrinsics, DACosD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL DACosD} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node DASin Intrinsic +@subsubsection DASin Intrinsic +@cindex DASin intrinsic +@cindex intrinsics, DASin + +@noindent +@example +DASin(@var{X}) +@end example + +@noindent +DASin: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{ASIN()} that is specific +to one type for @var{X}. +@xref{ASin Intrinsic}. + +@end ifset +@ifset familyVXT +@node DASinD Intrinsic +@subsubsection DASinD Intrinsic +@cindex DASinD intrinsic +@cindex intrinsics, DASinD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL DASinD} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node DATan Intrinsic +@subsubsection DATan Intrinsic +@cindex DATan intrinsic +@cindex intrinsics, DATan + +@noindent +@example +DATan(@var{X}) +@end example + +@noindent +DATan: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{ATAN()} that is specific +to one type for @var{X}. +@xref{ATan Intrinsic}. + +@node DATan2 Intrinsic +@subsubsection DATan2 Intrinsic +@cindex DATan2 intrinsic +@cindex intrinsics, DATan2 + +@noindent +@example +DATan2(@var{Y}, @var{X}) +@end example + +@noindent +DATan2: @code{REAL(KIND=2)} function. + +@noindent +@var{Y}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{ATAN2()} that is specific +to one type for @var{Y} and @var{X}. +@xref{ATan2 Intrinsic}. + +@end ifset +@ifset familyVXT +@node DATan2D Intrinsic +@subsubsection DATan2D Intrinsic +@cindex DATan2D intrinsic +@cindex intrinsics, DATan2D + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL DATan2D} to use this name for an +external procedure. + +@node DATanD Intrinsic +@subsubsection DATanD Intrinsic +@cindex DATanD intrinsic +@cindex intrinsics, DATanD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL DATanD} to use this name for an +external procedure. + +@node Date Intrinsic +@subsubsection Date Intrinsic +@cindex Date intrinsic +@cindex intrinsics, Date + +@noindent +@example +CALL Date(@var{Date}) +@end example + +@noindent +@var{Date}: @code{CHARACTER}; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{vxt}. + +@noindent +Description: + +Returns @var{Date} in the form @samp{@var{dd}-@var{mmm}-@var{yy}}, +representing the numeric day of the month @var{dd}, a three-character +abbreviation of the month name @var{mmm} and the last two digits of +the year @var{yy}, e.g.@ @samp{25-Nov-96}. + +This intrinsic is not recommended, due to the year 2000 approaching. +@xref{CTime Intrinsic (subroutine)}, for information on obtaining more digits +for the current (or any) date. + +@end ifset +@ifset familyF90 +@node Date_and_Time Intrinsic +@subsubsection Date_and_Time Intrinsic +@cindex Date_and_Time intrinsic +@cindex intrinsics, Date_and_Time + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Date_and_Time} to use this name for an +external procedure. + +@end ifset +@ifset familyF2U +@node DbesJ0 Intrinsic +@subsubsection DbesJ0 Intrinsic +@cindex DbesJ0 intrinsic +@cindex intrinsics, DbesJ0 + +@noindent +@example +DbesJ0(@var{X}) +@end example + +@noindent +DbesJ0: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Archaic form of @code{BESJ0()} that is specific +to one type for @var{X}. +@xref{BesJ0 Intrinsic}. + +@node DbesJ1 Intrinsic +@subsubsection DbesJ1 Intrinsic +@cindex DbesJ1 intrinsic +@cindex intrinsics, DbesJ1 + +@noindent +@example +DbesJ1(@var{X}) +@end example + +@noindent +DbesJ1: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Archaic form of @code{BESJ1()} that is specific +to one type for @var{X}. +@xref{BesJ1 Intrinsic}. + +@node DbesJN Intrinsic +@subsubsection DbesJN Intrinsic +@cindex DbesJN intrinsic +@cindex intrinsics, DbesJN + +@noindent +@example +DbesJN(@var{N}, @var{X}) +@end example + +@noindent +DbesJN: @code{REAL(KIND=2)} function. + +@noindent +@var{N}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Archaic form of @code{BESJN()} that is specific +to one type for @var{X}. +@xref{BesJN Intrinsic}. + +@node DbesY0 Intrinsic +@subsubsection DbesY0 Intrinsic +@cindex DbesY0 intrinsic +@cindex intrinsics, DbesY0 + +@noindent +@example +DbesY0(@var{X}) +@end example + +@noindent +DbesY0: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Archaic form of @code{BESY0()} that is specific +to one type for @var{X}. +@xref{BesY0 Intrinsic}. + +@node DbesY1 Intrinsic +@subsubsection DbesY1 Intrinsic +@cindex DbesY1 intrinsic +@cindex intrinsics, DbesY1 + +@noindent +@example +DbesY1(@var{X}) +@end example + +@noindent +DbesY1: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Archaic form of @code{BESY1()} that is specific +to one type for @var{X}. +@xref{BesY1 Intrinsic}. + +@node DbesYN Intrinsic +@subsubsection DbesYN Intrinsic +@cindex DbesYN intrinsic +@cindex intrinsics, DbesYN + +@noindent +@example +DbesYN(@var{N}, @var{X}) +@end example + +@noindent +DbesYN: @code{REAL(KIND=2)} function. + +@noindent +@var{N}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Archaic form of @code{BESYN()} that is specific +to one type for @var{X}. +@xref{BesYN Intrinsic}. + +@end ifset +@ifset familyF77 +@node Dble Intrinsic +@subsubsection Dble Intrinsic +@cindex Dble intrinsic +@cindex intrinsics, Dble + +@noindent +@example +Dble(@var{A}) +@end example + +@noindent +Dble: @code{REAL(KIND=2)} function. + +@noindent +@var{A}: @code{INTEGER}, @code{REAL}, or @code{COMPLEX}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns @var{A} converted to double precision +(@code{REAL(KIND=2)}). +If @var{A} is @code{COMPLEX}, the real part of +@var{A} is used for the conversion +and the imaginary part disregarded. + +@xref{Sngl Intrinsic}, for the function that converts +to single precision. + +@xref{Int Intrinsic}, for the function that converts +to @code{INTEGER}. + +@xref{Complex Intrinsic}, for the function that converts +to @code{COMPLEX}. + +@end ifset +@ifset familyVXT +@node DbleQ Intrinsic +@subsubsection DbleQ Intrinsic +@cindex DbleQ intrinsic +@cindex intrinsics, DbleQ + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL DbleQ} to use this name for an +external procedure. + +@end ifset +@ifset familyFVZ +@node DCmplx Intrinsic +@subsubsection DCmplx Intrinsic +@cindex DCmplx intrinsic +@cindex intrinsics, DCmplx + +@noindent +@example +DCmplx(@var{X}, @var{Y}) +@end example + +@noindent +DCmplx: @code{COMPLEX(KIND=2)} function. + +@noindent +@var{X}: @code{INTEGER}, @code{REAL}, or @code{COMPLEX}; scalar; INTENT(IN). + +@noindent +@var{Y}: @code{INTEGER} or @code{REAL}; OPTIONAL (must be omitted if @var{X} is @code{COMPLEX}); scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}, @code{vxt}. + +@noindent +Description: + +If @var{X} is not type @code{COMPLEX}, +constructs a value of type @code{COMPLEX(KIND=2)} from the +real and imaginary values specified by @var{X} and +@var{Y}, respectively. +If @var{Y} is omitted, @samp{0D0} is assumed. + +If @var{X} is type @code{COMPLEX}, +converts it to type @code{COMPLEX(KIND=2)}. + +Although this intrinsic is not standard Fortran, +it is a popular extension offered by many compilers +that support @code{DOUBLE COMPLEX}, since it offers +the easiest way to convert to @code{DOUBLE COMPLEX} +without using Fortran 90 features (such as the @samp{KIND=} +argument to the @code{CMPLX()} intrinsic). + +(@samp{CMPLX(0D0, 0D0)} returns a single-precision +@code{COMPLEX} result, as required by standard FORTRAN 77. +That's why so many compilers provide @code{DCMPLX()}, since +@samp{DCMPLX(0D0, 0D0)} returns a @code{DOUBLE COMPLEX} +result. +Still, @code{DCMPLX()} converts even @code{REAL*16} arguments +to their @code{REAL*8} equivalents in most dialects of +Fortran, so neither it nor @code{CMPLX()} allow easy +construction of arbitrary-precision values without +potentially forcing a conversion involving extending or +reducing precision. +GNU Fortran provides such an intrinsic, called @code{COMPLEX()}.) + +@xref{Complex Intrinsic}, for information on easily constructing +a @code{COMPLEX} value of arbitrary precision from @code{REAL} +arguments. + +@node DConjg Intrinsic +@subsubsection DConjg Intrinsic +@cindex DConjg intrinsic +@cindex intrinsics, DConjg + +@noindent +@example +DConjg(@var{Z}) +@end example + +@noindent +DConjg: @code{COMPLEX(KIND=2)} function. + +@noindent +@var{Z}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}, @code{vxt}. + +@noindent +Description: + +Archaic form of @code{CONJG()} that is specific +to one type for @var{Z}. +@xref{ATan2 Intrinsic}. + +@end ifset +@ifset familyF77 +@node DCos Intrinsic +@subsubsection DCos Intrinsic +@cindex DCos intrinsic +@cindex intrinsics, DCos + +@noindent +@example +DCos(@var{X}) +@end example + +@noindent +DCos: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{COS()} that is specific +to one type for @var{X}. +@xref{Cos Intrinsic}. + +@end ifset +@ifset familyVXT +@node DCosD Intrinsic +@subsubsection DCosD Intrinsic +@cindex DCosD intrinsic +@cindex intrinsics, DCosD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL DCosD} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node DCosH Intrinsic +@subsubsection DCosH Intrinsic +@cindex DCosH intrinsic +@cindex intrinsics, DCosH + +@noindent +@example +DCosH(@var{X}) +@end example + +@noindent +DCosH: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{COSH()} that is specific +to one type for @var{X}. +@xref{CosH Intrinsic}. + +@node DDiM Intrinsic +@subsubsection DDiM Intrinsic +@cindex DDiM intrinsic +@cindex intrinsics, DDiM + +@noindent +@example +DDiM(@var{X}, @var{Y}) +@end example + +@noindent +DDiM: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +@var{Y}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{DIM()} that is specific +to one type for @var{X} and @var{Y}. +@xref{DiM Intrinsic}. + +@end ifset +@ifset familyF2U +@node DErF Intrinsic +@subsubsection DErF Intrinsic +@cindex DErF intrinsic +@cindex intrinsics, DErF + +@noindent +@example +DErF(@var{X}) +@end example + +@noindent +DErF: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Archaic form of @code{ERF()} that is specific +to one type for @var{X}. +@xref{ErF Intrinsic}. + +@node DErFC Intrinsic +@subsubsection DErFC Intrinsic +@cindex DErFC intrinsic +@cindex intrinsics, DErFC + +@noindent +@example +DErFC(@var{X}) +@end example + +@noindent +DErFC: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Archaic form of @code{ERFC()} that is specific +to one type for @var{X}. +@xref{ErFC Intrinsic}. + +@end ifset +@ifset familyF77 +@node DExp Intrinsic +@subsubsection DExp Intrinsic +@cindex DExp intrinsic +@cindex intrinsics, DExp + +@noindent +@example +DExp(@var{X}) +@end example + +@noindent +DExp: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{EXP()} that is specific +to one type for @var{X}. +@xref{Exp Intrinsic}. + +@end ifset +@ifset familyFVZ +@node DFloat Intrinsic +@subsubsection DFloat Intrinsic +@cindex DFloat intrinsic +@cindex intrinsics, DFloat + +@noindent +@example +DFloat(@var{A}) +@end example + +@noindent +DFloat: @code{REAL(KIND=2)} function. + +@noindent +@var{A}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}, @code{vxt}. + +@noindent +Description: + +Archaic form of @code{REAL()} that is specific +to one type for @var{A}. +@xref{Real Intrinsic}. + +@end ifset +@ifset familyVXT +@node DFlotI Intrinsic +@subsubsection DFlotI Intrinsic +@cindex DFlotI intrinsic +@cindex intrinsics, DFlotI + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL DFlotI} to use this name for an +external procedure. + +@node DFlotJ Intrinsic +@subsubsection DFlotJ Intrinsic +@cindex DFlotJ intrinsic +@cindex intrinsics, DFlotJ + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL DFlotJ} to use this name for an +external procedure. + +@end ifset +@ifset familyF90 +@node Digits Intrinsic +@subsubsection Digits Intrinsic +@cindex Digits intrinsic +@cindex intrinsics, Digits + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Digits} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node DiM Intrinsic +@subsubsection DiM Intrinsic +@cindex DiM intrinsic +@cindex intrinsics, DiM + +@noindent +@example +DiM(@var{X}, @var{Y}) +@end example + +@noindent +DiM: @code{INTEGER} or @code{REAL} function, the exact type being the result of cross-promoting the +types of all the arguments. + +@noindent +@var{X}: @code{INTEGER} or @code{REAL}; scalar; INTENT(IN). + +@noindent +@var{Y}: @code{INTEGER} or @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns @samp{@var{X}-@var{Y}} if @var{X} is greater than +@var{Y}; otherwise returns zero. + +@end ifset +@ifset familyFVZ +@node DImag Intrinsic +@subsubsection DImag Intrinsic +@cindex DImag intrinsic +@cindex intrinsics, DImag + +@noindent +@example +DImag(@var{Z}) +@end example + +@noindent +DImag: @code{REAL(KIND=2)} function. + +@noindent +@var{Z}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}, @code{vxt}. + +@noindent +Description: + +Archaic form of @code{AIMAG()} that is specific +to one type for @var{Z}. +@xref{AImag Intrinsic}. + +@end ifset +@ifset familyF77 +@node DInt Intrinsic +@subsubsection DInt Intrinsic +@cindex DInt intrinsic +@cindex intrinsics, DInt + +@noindent +@example +DInt(@var{A}) +@end example + +@noindent +DInt: @code{REAL(KIND=2)} function. + +@noindent +@var{A}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{AINT()} that is specific +to one type for @var{A}. +@xref{AInt Intrinsic}. + +@node DLog Intrinsic +@subsubsection DLog Intrinsic +@cindex DLog intrinsic +@cindex intrinsics, DLog + +@noindent +@example +DLog(@var{X}) +@end example + +@noindent +DLog: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{LOG()} that is specific +to one type for @var{X}. +@xref{Log Intrinsic}. + +@node DLog10 Intrinsic +@subsubsection DLog10 Intrinsic +@cindex DLog10 intrinsic +@cindex intrinsics, DLog10 + +@noindent +@example +DLog10(@var{X}) +@end example + +@noindent +DLog10: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{LOG10()} that is specific +to one type for @var{X}. +@xref{Log10 Intrinsic}. + +@node DMax1 Intrinsic +@subsubsection DMax1 Intrinsic +@cindex DMax1 intrinsic +@cindex intrinsics, DMax1 + +@noindent +@example +DMax1(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n) +@end example + +@noindent +DMax1: @code{REAL(KIND=2)} function. + +@noindent +@var{A}: @code{REAL(KIND=2)}; at least two such arguments must be provided; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{MAX()} that is specific +to one type for @var{A}. +@xref{Max Intrinsic}. + +@node DMin1 Intrinsic +@subsubsection DMin1 Intrinsic +@cindex DMin1 intrinsic +@cindex intrinsics, DMin1 + +@noindent +@example +DMin1(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n) +@end example + +@noindent +DMin1: @code{REAL(KIND=2)} function. + +@noindent +@var{A}: @code{REAL(KIND=2)}; at least two such arguments must be provided; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{MIN()} that is specific +to one type for @var{A}. +@xref{Min Intrinsic}. + +@node DMod Intrinsic +@subsubsection DMod Intrinsic +@cindex DMod intrinsic +@cindex intrinsics, DMod + +@noindent +@example +DMod(@var{A}, @var{P}) +@end example + +@noindent +DMod: @code{REAL(KIND=2)} function. + +@noindent +@var{A}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +@var{P}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{MOD()} that is specific +to one type for @var{A}. +@xref{Mod Intrinsic}. + +@node DNInt Intrinsic +@subsubsection DNInt Intrinsic +@cindex DNInt intrinsic +@cindex intrinsics, DNInt + +@noindent +@example +DNInt(@var{A}) +@end example + +@noindent +DNInt: @code{REAL(KIND=2)} function. + +@noindent +@var{A}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{ANINT()} that is specific +to one type for @var{A}. +@xref{ANInt Intrinsic}. + +@end ifset +@ifset familyF90 +@node Dot_Product Intrinsic +@subsubsection Dot_Product Intrinsic +@cindex Dot_Product intrinsic +@cindex intrinsics, Dot_Product + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Dot_Product} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node DProd Intrinsic +@subsubsection DProd Intrinsic +@cindex DProd intrinsic +@cindex intrinsics, DProd + +@noindent +@example +DProd(@var{X}, @var{Y}) +@end example + +@noindent +DProd: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=1)}; scalar; INTENT(IN). + +@noindent +@var{Y}: @code{REAL(KIND=1)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns @samp{DBLE(@var{X})*DBLE(@var{Y})}. + +@end ifset +@ifset familyVXT +@node DReal Intrinsic +@subsubsection DReal Intrinsic +@cindex DReal intrinsic +@cindex intrinsics, DReal + +@noindent +@example +DReal(@var{A}) +@end example + +@noindent +DReal: @code{REAL(KIND=2)} function. + +@noindent +@var{A}: @code{INTEGER}, @code{REAL}, or @code{COMPLEX}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{vxt}. + +@noindent +Description: + +Converts @var{A} to @code{REAL(KIND=2)}. + +If @var{A} is type @code{COMPLEX}, its real part +is converted (if necessary) to @code{REAL(KIND=2)}, +and its imaginary part is disregarded. + +Although this intrinsic is not standard Fortran, +it is a popular extension offered by many compilers +that support @code{DOUBLE COMPLEX}, since it offers +the easiest way to extract the real part of a @code{DOUBLE COMPLEX} +value without using the Fortran 90 @code{REAL()} intrinsic +in a way that produces a return value inconsistent with +the way many FORTRAN 77 compilers handle @code{REAL()} of +a @code{DOUBLE COMPLEX} value. + +@xref{RealPart Intrinsic}, for information on a GNU Fortran +intrinsic that avoids these areas of confusion. + +@xref{REAL() and AIMAG() of Complex}, for more information on +this issue. + +@end ifset +@ifset familyF77 +@node DSign Intrinsic +@subsubsection DSign Intrinsic +@cindex DSign intrinsic +@cindex intrinsics, DSign + +@noindent +@example +DSign(@var{A}, @var{B}) +@end example + +@noindent +DSign: @code{REAL(KIND=2)} function. + +@noindent +@var{A}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +@var{B}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{SIGN()} that is specific +to one type for @var{A} and @var{B}. +@xref{Sign Intrinsic}. + +@node DSin Intrinsic +@subsubsection DSin Intrinsic +@cindex DSin intrinsic +@cindex intrinsics, DSin + +@noindent +@example +DSin(@var{X}) +@end example + +@noindent +DSin: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{SIN()} that is specific +to one type for @var{X}. +@xref{Sin Intrinsic}. + +@end ifset +@ifset familyVXT +@node DSinD Intrinsic +@subsubsection DSinD Intrinsic +@cindex DSinD intrinsic +@cindex intrinsics, DSinD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL DSinD} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node DSinH Intrinsic +@subsubsection DSinH Intrinsic +@cindex DSinH intrinsic +@cindex intrinsics, DSinH + +@noindent +@example +DSinH(@var{X}) +@end example + +@noindent +DSinH: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{SINH()} that is specific +to one type for @var{X}. +@xref{SinH Intrinsic}. + +@node DSqRt Intrinsic +@subsubsection DSqRt Intrinsic +@cindex DSqRt intrinsic +@cindex intrinsics, DSqRt + +@noindent +@example +DSqRt(@var{X}) +@end example + +@noindent +DSqRt: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{SQRT()} that is specific +to one type for @var{X}. +@xref{SqRt Intrinsic}. + +@node DTan Intrinsic +@subsubsection DTan Intrinsic +@cindex DTan intrinsic +@cindex intrinsics, DTan + +@noindent +@example +DTan(@var{X}) +@end example + +@noindent +DTan: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{TAN()} that is specific +to one type for @var{X}. +@xref{Tan Intrinsic}. + +@end ifset +@ifset familyVXT +@node DTanD Intrinsic +@subsubsection DTanD Intrinsic +@cindex DTanD intrinsic +@cindex intrinsics, DTanD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL DTanD} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node DTanH Intrinsic +@subsubsection DTanH Intrinsic +@cindex DTanH intrinsic +@cindex intrinsics, DTanH + +@noindent +@example +DTanH(@var{X}) +@end example + +@noindent +DTanH: @code{REAL(KIND=2)} function. + +@noindent +@var{X}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{TANH()} that is specific +to one type for @var{X}. +@xref{TanH Intrinsic}. + +@end ifset +@ifset familyF2U +@node Dtime Intrinsic (subroutine) +@subsubsection Dtime Intrinsic (subroutine) +@cindex Dtime intrinsic +@cindex intrinsics, Dtime + +@noindent +@example +CALL Dtime(@var{Result}, @var{TArray}) +@end example + +@noindent +@var{Result}: @code{REAL(KIND=1)}; scalar; INTENT(OUT). + +@noindent +@var{TArray}: @code{REAL(KIND=1)}; DIMENSION(2); INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Initially, return the number of seconds of runtime +since the start of the process's execution +in @var{Result}, +and the user and system components of this in @samp{@var{TArray}(1)} +and @samp{@var{TArray}(2)} respectively. +The value of @var{Result} is equal to @samp{@var{TArray}(1) + @var{TArray}(2)}. + +Subsequent invocations of @samp{DTIME()} set values based on accumulations +since the previous invocation. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine. + +For information on other intrinsics with the same name: +@xref{Dtime Intrinsic (function)}. + +@end ifset +@ifset familyBADU77 +@node Dtime Intrinsic (function) +@subsubsection Dtime Intrinsic (function) +@cindex Dtime intrinsic +@cindex intrinsics, Dtime + +@noindent +@example +Dtime(@var{TArray}) +@end example + +@noindent +Dtime: @code{REAL(KIND=1)} function. + +@noindent +@var{TArray}: @code{REAL(KIND=1)}; DIMENSION(2); INTENT(OUT). + +@noindent +Intrinsic groups: @code{badu77}. + +@noindent +Description: + +Initially, return the number of seconds of runtime +since the start of the process's execution +as the function value, +and the user and system components of this in @samp{@var{TArray}(1)} +and @samp{@var{TArray}(2)} respectively. +The functions' value is equal to @samp{@var{TArray}(1) + @var{TArray}(2)}. + +Subsequent invocations of @samp{DTIME()} return values accumulated since the +previous invocation. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. + +For information on other intrinsics with the same name: +@xref{Dtime Intrinsic (subroutine)}. + +@end ifset +@ifset familyF90 +@node EOShift Intrinsic +@subsubsection EOShift Intrinsic +@cindex EOShift intrinsic +@cindex intrinsics, EOShift + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL EOShift} to use this name for an +external procedure. + +@node Epsilon Intrinsic +@subsubsection Epsilon Intrinsic +@cindex Epsilon intrinsic +@cindex intrinsics, Epsilon + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Epsilon} to use this name for an +external procedure. + +@end ifset +@ifset familyF2U +@node ErF Intrinsic +@subsubsection ErF Intrinsic +@cindex ErF intrinsic +@cindex intrinsics, ErF + +@noindent +@example +ErF(@var{X}) +@end example + +@noindent +ErF: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the error function of @var{X}. +See @code{erf(3m)}, which provides the implementation. + +@node ErFC Intrinsic +@subsubsection ErFC Intrinsic +@cindex ErFC intrinsic +@cindex intrinsics, ErFC + +@noindent +@example +ErFC(@var{X}) +@end example + +@noindent +ErFC: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the complementary error function of @var{X}: +@samp{ERFC(R) = 1 - ERF(R)} (except that the result may be more +accurate than explicitly evaluating that formulae would give). +See @code{erfc(3m)}, which provides the implementation. + +@node ETime Intrinsic (subroutine) +@subsubsection ETime Intrinsic (subroutine) +@cindex ETime intrinsic +@cindex intrinsics, ETime + +@noindent +@example +CALL ETime(@var{Result}, @var{TArray}) +@end example + +@noindent +@var{Result}: @code{REAL(KIND=1)}; scalar; INTENT(OUT). + +@noindent +@var{TArray}: @code{REAL(KIND=1)}; DIMENSION(2); INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Return the number of seconds of runtime +since the start of the process's execution +in @var{Result}, +and the user and system components of this in @samp{@var{TArray}(1)} +and @samp{@var{TArray}(2)} respectively. +The value of @var{Result} is equal to @samp{@var{TArray}(1) + @var{TArray}(2)}. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine. + +For information on other intrinsics with the same name: +@xref{ETime Intrinsic (function)}. + +@node ETime Intrinsic (function) +@subsubsection ETime Intrinsic (function) +@cindex ETime intrinsic +@cindex intrinsics, ETime + +@noindent +@example +ETime(@var{TArray}) +@end example + +@noindent +ETime: @code{REAL(KIND=1)} function. + +@noindent +@var{TArray}: @code{REAL(KIND=1)}; DIMENSION(2); INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Return the number of seconds of runtime +since the start of the process's execution +as the function value, +and the user and system components of this in @samp{@var{TArray}(1)} +and @samp{@var{TArray}(2)} respectively. +The functions' value is equal to @samp{@var{TArray}(1) + @var{TArray}(2)}. + +For information on other intrinsics with the same name: +@xref{ETime Intrinsic (subroutine)}. + +@node Exit Intrinsic +@subsubsection Exit Intrinsic +@cindex Exit intrinsic +@cindex intrinsics, Exit + +@noindent +@example +CALL Exit(@var{Status}) +@end example + +@noindent +@var{Status}: @code{INTEGER}; OPTIONAL; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Exit the program with status @var{Status} after closing open Fortran +I/O units and otherwise behaving as @code{exit(2)}. +If @var{Status} is omitted the canonical `success' value +will be returned to the system. + +@end ifset +@ifset familyF77 +@node Exp Intrinsic +@subsubsection Exp Intrinsic +@cindex Exp intrinsic +@cindex intrinsics, Exp + +@noindent +@example +Exp(@var{X}) +@end example + +@noindent +Exp: @code{REAL} or @code{COMPLEX} function, the exact type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL} or @code{COMPLEX}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns @samp{@var{e}**@var{X}}, where +@var{e} is approximately 2.7182818. + +@xref{Log Intrinsic}, for the inverse of this function. + +@end ifset +@ifset familyF90 +@node Exponent Intrinsic +@subsubsection Exponent Intrinsic +@cindex Exponent intrinsic +@cindex intrinsics, Exponent + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Exponent} to use this name for an +external procedure. + +@end ifset +@ifset familyF2U +@node Fdate Intrinsic (subroutine) +@subsubsection Fdate Intrinsic (subroutine) +@cindex Fdate intrinsic +@cindex intrinsics, Fdate + +@noindent +@example +CALL Fdate(@var{Date}) +@end example + +@noindent +@var{Date}: @code{CHARACTER}; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the current date (using the same format as @code{CTIME()}) +in @var{Date}. + +Equivalent to: + +@example +CALL CTIME(@var{Date}, TIME8()) +@end example + +@xref{CTime Intrinsic (subroutine)}. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine. + +For information on other intrinsics with the same name: +@xref{Fdate Intrinsic (function)}. + +@node Fdate Intrinsic (function) +@subsubsection Fdate Intrinsic (function) +@cindex Fdate intrinsic +@cindex intrinsics, Fdate + +@noindent +@example +Fdate() +@end example + +@noindent +Fdate: @code{CHARACTER*(*)} function. + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the current date (using the same format as @code{CTIME()}). + +Equivalent to: + +@example +CTIME(TIME8()) +@end example + +@xref{CTime Intrinsic (function)}. + +For information on other intrinsics with the same name: +@xref{Fdate Intrinsic (subroutine)}. + +@node FGet Intrinsic (subroutine) +@subsubsection FGet Intrinsic (subroutine) +@cindex FGet intrinsic +@cindex intrinsics, FGet + +@noindent +@example +CALL FGet(@var{C}, @var{Status}) +@end example + +@noindent +@var{C}: @code{CHARACTER}; scalar; INTENT(OUT). + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Reads a single character into @var{C} in stream mode from unit 5 +(by-passing normal formatted output) using @code{getc(3)}. +Returns in +@var{Status} 0 on success, @minus{}1 on end-of-file, and the error code +from @code{ferror(3)} otherwise. + +Stream I/O should not be mixed with normal record-oriented (formatted or +unformatted) I/O on the same unit; the results are unpredictable. + +For information on other intrinsics with the same name: +@xref{FGet Intrinsic (function)}. + +@end ifset +@ifset familyBADU77 +@node FGet Intrinsic (function) +@subsubsection FGet Intrinsic (function) +@cindex FGet intrinsic +@cindex intrinsics, FGet + +@noindent +@example +FGet(@var{C}) +@end example + +@noindent +FGet: @code{INTEGER(KIND=1)} function. + +@noindent +@var{C}: @code{CHARACTER}; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{badu77}. + +@noindent +Description: + +Reads a single character into @var{C} in stream mode from unit 5 +(by-passing normal formatted input) using @code{getc(3)}. +Returns 0 on +success, @minus{}1 on end-of-file, and the error code from +@code{ferror(3)} otherwise. + +Stream I/O should not be mixed with normal record-oriented (formatted or +unformatted) I/O on the same unit; the results are unpredictable. + +For information on other intrinsics with the same name: +@xref{FGet Intrinsic (subroutine)}. + +@end ifset +@ifset familyF2U +@node FGetC Intrinsic (subroutine) +@subsubsection FGetC Intrinsic (subroutine) +@cindex FGetC intrinsic +@cindex intrinsics, FGetC + +@noindent +@example +CALL FGetC(@var{Unit}, @var{C}, @var{Status}) +@end example + +@noindent +@var{Unit}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{C}: @code{CHARACTER}; scalar; INTENT(OUT). + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Reads a single character into @var{C} in stream mode from unit @var{Unit} +(by-passing normal formatted output) using @code{getc(3)}. +Returns in +@var{Status} 0 on success, @minus{}1 on end-of-file, and the error code from +@code{ferror(3)} otherwise. + +Stream I/O should not be mixed with normal record-oriented (formatted or +unformatted) I/O on the same unit; the results are unpredictable. + +For information on other intrinsics with the same name: +@xref{FGetC Intrinsic (function)}. + +@end ifset +@ifset familyBADU77 +@node FGetC Intrinsic (function) +@subsubsection FGetC Intrinsic (function) +@cindex FGetC intrinsic +@cindex intrinsics, FGetC + +@noindent +@example +FGetC(@var{Unit}, @var{C}) +@end example + +@noindent +FGetC: @code{INTEGER(KIND=1)} function. + +@noindent +@var{Unit}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{C}: @code{CHARACTER}; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{badu77}. + +@noindent +Description: + +Reads a single character into @var{C} in stream mode from unit @var{Unit} +(by-passing normal formatted output) using @code{getc(3)}. +Returns 0 on +success, @minus{}1 on end-of-file, and the error code from +@code{ferror(3)} otherwise. + +Stream I/O should not be mixed with normal record-oriented (formatted or +unformatted) I/O on the same unit; the results are unpredictable. + +For information on other intrinsics with the same name: +@xref{FGetC Intrinsic (subroutine)}. + +@end ifset +@ifset familyF77 +@node Float Intrinsic +@subsubsection Float Intrinsic +@cindex Float intrinsic +@cindex intrinsics, Float + +@noindent +@example +Float(@var{A}) +@end example + +@noindent +Float: @code{REAL(KIND=1)} function. + +@noindent +@var{A}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{REAL()} that is specific +to one type for @var{A}. +@xref{Real Intrinsic}. + +@end ifset +@ifset familyVXT +@node FloatI Intrinsic +@subsubsection FloatI Intrinsic +@cindex FloatI intrinsic +@cindex intrinsics, FloatI + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL FloatI} to use this name for an +external procedure. + +@node FloatJ Intrinsic +@subsubsection FloatJ Intrinsic +@cindex FloatJ intrinsic +@cindex intrinsics, FloatJ + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL FloatJ} to use this name for an +external procedure. + +@end ifset +@ifset familyF90 +@node Floor Intrinsic +@subsubsection Floor Intrinsic +@cindex Floor intrinsic +@cindex intrinsics, Floor + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Floor} to use this name for an +external procedure. + +@end ifset +@ifset familyF2U +@node Flush Intrinsic +@subsubsection Flush Intrinsic +@cindex Flush intrinsic +@cindex intrinsics, Flush + +@noindent +@example +CALL Flush(@var{Unit}) +@end example + +@noindent +@var{Unit}: @code{INTEGER}; OPTIONAL; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Flushes Fortran unit(s) currently open for output. +Without the optional argument, all such units are flushed, +otherwise just the unit specified by @var{Unit}. + +Some non-GNU implementations of Fortran provide this intrinsic +as a library procedure that might or might not support the +(optional) @var{Unit} argument. + +@node FNum Intrinsic +@subsubsection FNum Intrinsic +@cindex FNum intrinsic +@cindex intrinsics, FNum + +@noindent +@example +FNum(@var{Unit}) +@end example + +@noindent +FNum: @code{INTEGER(KIND=1)} function. + +@noindent +@var{Unit}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the Unix file descriptor number corresponding to the open +Fortran I/O unit @var{Unit}. +This could be passed to an interface to C I/O routines. + +@node FPut Intrinsic (subroutine) +@subsubsection FPut Intrinsic (subroutine) +@cindex FPut intrinsic +@cindex intrinsics, FPut + +@noindent +@example +CALL FPut(@var{C}, @var{Status}) +@end example + +@noindent +@var{C}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Writes the single character @var{C} in stream mode to unit 6 +(by-passing normal formatted output) using @code{putc(3)}. +Returns in +@var{Status} 0 on success, the error code from @code{ferror(3)} otherwise. + +Stream I/O should not be mixed with normal record-oriented (formatted or +unformatted) I/O on the same unit; the results are unpredictable. + +For information on other intrinsics with the same name: +@xref{FPut Intrinsic (function)}. + +@end ifset +@ifset familyBADU77 +@node FPut Intrinsic (function) +@subsubsection FPut Intrinsic (function) +@cindex FPut intrinsic +@cindex intrinsics, FPut + +@noindent +@example +FPut(@var{C}) +@end example + +@noindent +FPut: @code{INTEGER(KIND=1)} function. + +@noindent +@var{C}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{badu77}. + +@noindent +Description: + +Writes the single character @var{C} in stream mode to unit 6 +(by-passing normal formatted output) using @code{getc(3)}. +Returns 0 on +success, the error code from @code{ferror(3)} otherwise. + +Stream I/O should not be mixed with normal record-oriented (formatted or +unformatted) I/O on the same unit; the results are unpredictable. + +For information on other intrinsics with the same name: +@xref{FPut Intrinsic (subroutine)}. + +@end ifset +@ifset familyF2U +@node FPutC Intrinsic (subroutine) +@subsubsection FPutC Intrinsic (subroutine) +@cindex FPutC intrinsic +@cindex intrinsics, FPutC + +@noindent +@example +CALL FPutC(@var{Unit}, @var{C}, @var{Status}) +@end example + +@noindent +@var{Unit}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{C}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Writes the single character @var{Unit} in stream mode to unit 6 +(by-passing normal formatted output) using @code{putc(3)}. +Returns in +@var{C} 0 on success, the error code from @code{ferror(3)} otherwise. + +Stream I/O should not be mixed with normal record-oriented (formatted or +unformatted) I/O on the same unit; the results are unpredictable. + +For information on other intrinsics with the same name: +@xref{FPutC Intrinsic (function)}. + +@end ifset +@ifset familyBADU77 +@node FPutC Intrinsic (function) +@subsubsection FPutC Intrinsic (function) +@cindex FPutC intrinsic +@cindex intrinsics, FPutC + +@noindent +@example +FPutC(@var{Unit}, @var{C}) +@end example + +@noindent +FPutC: @code{INTEGER(KIND=1)} function. + +@noindent +@var{Unit}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{C}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{badu77}. + +@noindent +Description: + +Writes the single character @var{C} in stream mode to unit @var{Unit} +(by-passing normal formatted output) using @code{putc(3)}. +Returns 0 on +success, the error code from @code{ferror(3)} otherwise. + +Stream I/O should not be mixed with normal record-oriented (formatted or +unformatted) I/O on the same unit; the results are unpredictable. + +For information on other intrinsics with the same name: +@xref{FPutC Intrinsic (subroutine)}. + +@end ifset +@ifset familyF90 +@node Fraction Intrinsic +@subsubsection Fraction Intrinsic +@cindex Fraction intrinsic +@cindex intrinsics, Fraction + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Fraction} to use this name for an +external procedure. + +@end ifset +@ifset familyF2U +@node FSeek Intrinsic +@subsubsection FSeek Intrinsic +@cindex FSeek intrinsic +@cindex intrinsics, FSeek + +@noindent +@example +CALL FSeek(@var{Unit}, @var{Offset}, @var{Whence}, @var{ErrLab}) +@end example + +@noindent +@var{Unit}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Offset}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Whence}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{ErrLab}: @samp{*@var{label}}, where @var{label} is the label +of an executable statement; OPTIONAL. + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Attempts to move Fortran unit @var{Unit} to the specified +@var{Offset}: absolute offset if @var{Offset}=0; relative to the +current offset if @var{Offset}=1; relative to the end of the file if +@var{Offset}=2. +It branches to label @var{Whence} if @var{Unit} is +not open or if the call otherwise fails. + +@node FStat Intrinsic (subroutine) +@subsubsection FStat Intrinsic (subroutine) +@cindex FStat intrinsic +@cindex intrinsics, FStat + +@noindent +@example +CALL FStat(@var{Unit}, @var{SArray}, @var{Status}) +@end example + +@noindent +@var{Unit}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{SArray}: @code{INTEGER(KIND=1)}; DIMENSION(13); INTENT(OUT). + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Obtains data about the file open on Fortran I/O unit @var{Unit} and +places them in the array @var{SArray}. +The values in this array are +extracted from the @code{stat} structure as returned by +@code{fstat(2)} q.v., as follows: + +@enumerate +@item +File mode + +@item +Inode number + +@item +ID of device containing directory entry for file + +@item +Device id (if relevant) + +@item +Number of links + +@item +Owner's uid + +@item +Owner's gid + +@item +File size (bytes) + +@item +Last access time + +@item +Last modification time + +@item +Last file status change time + +@item +Preferred I/O block size + +@item +Number of blocks allocated +@end enumerate + +Not all these elements are relevant on all systems. +If an element is not relevant, it is returned as 0. + +If the @var{Status} argument is supplied, it contains +0 on success or a non-zero error code upon return. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{Status} argument. + +For information on other intrinsics with the same name: +@xref{FStat Intrinsic (function)}. + +@node FStat Intrinsic (function) +@subsubsection FStat Intrinsic (function) +@cindex FStat intrinsic +@cindex intrinsics, FStat + +@noindent +@example +FStat(@var{Unit}, @var{SArray}) +@end example + +@noindent +FStat: @code{INTEGER(KIND=1)} function. + +@noindent +@var{Unit}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{SArray}: @code{INTEGER(KIND=1)}; DIMENSION(13); INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Obtains data about the file open on Fortran I/O unit @var{Unit} and +places them in the array @var{SArray}. +The values in this array are +extracted from the @code{stat} structure as returned by +@code{fstat(2)} q.v., as follows: + +@enumerate +@item +File mode + +@item +Inode number + +@item +ID of device containing directory entry for file + +@item +Device id (if relevant) + +@item +Number of links + +@item +Owner's uid + +@item +Owner's gid + +@item +File size (bytes) + +@item +Last access time + +@item +Last modification time + +@item +Last file status change time + +@item +Preferred I/O block size + +@item +Number of blocks allocated +@end enumerate + +Not all these elements are relevant on all systems. +If an element is not relevant, it is returned as 0. + +Returns 0 on success or a non-zero error code. + +For information on other intrinsics with the same name: +@xref{FStat Intrinsic (subroutine)}. + +@node FTell Intrinsic (subroutine) +@subsubsection FTell Intrinsic (subroutine) +@cindex FTell intrinsic +@cindex intrinsics, FTell + +@noindent +@example +CALL FTell(@var{Unit}, @var{Offset}) +@end example + +@noindent +@var{Unit}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Offset}: @code{INTEGER(KIND=1)}; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Sets @var{Offset} to the current offset of Fortran unit @var{Unit} +(or to @minus{}1 if @var{Unit} is not open). + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine. + +For information on other intrinsics with the same name: +@xref{FTell Intrinsic (function)}. + +@node FTell Intrinsic (function) +@subsubsection FTell Intrinsic (function) +@cindex FTell intrinsic +@cindex intrinsics, FTell + +@noindent +@example +FTell(@var{Unit}) +@end example + +@noindent +FTell: @code{INTEGER(KIND=1)} function. + +@noindent +@var{Unit}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the current offset of Fortran unit @var{Unit} +(or @minus{}1 if @var{Unit} is not open). + +For information on other intrinsics with the same name: +@xref{FTell Intrinsic (subroutine)}. + +@node GError Intrinsic +@subsubsection GError Intrinsic +@cindex GError intrinsic +@cindex intrinsics, GError + +@noindent +@example +CALL GError(@var{Message}) +@end example + +@noindent +@var{Message}: @code{CHARACTER}; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the system error message corresponding to the last system +error (C @code{errno}). + +@node GetArg Intrinsic +@subsubsection GetArg Intrinsic +@cindex GetArg intrinsic +@cindex intrinsics, GetArg + +@noindent +@example +CALL GetArg(@var{Pos}, @var{Value}) +@end example + +@noindent +@var{Pos}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Value}: @code{CHARACTER}; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Sets @var{Value} to the @var{Pos}-th command-line argument (or to all +blanks if there are fewer than @var{Value} command-line arguments); +@code{CALL GETARG(0, @var{value})} sets @var{value} to the name of the +program (on systems that support this feature). + +@xref{IArgC Intrinsic}, for information on how to get the number +of arguments. + +@node GetCWD Intrinsic (subroutine) +@subsubsection GetCWD Intrinsic (subroutine) +@cindex GetCWD intrinsic +@cindex intrinsics, GetCWD + +@noindent +@example +CALL GetCWD(@var{Name}, @var{Status}) +@end example + +@noindent +@var{Name}: @code{CHARACTER}; scalar; INTENT(OUT). + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Places the current working directory in @var{Name}. +If the @var{Status} argument is supplied, it contains 0 +success or a non-zero error code upon return +(@code{ENOSYS} if the system does not provide @code{getcwd(3)} +or @code{getwd(3)}). + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{Status} argument. + +For information on other intrinsics with the same name: +@xref{GetCWD Intrinsic (function)}. + +@node GetCWD Intrinsic (function) +@subsubsection GetCWD Intrinsic (function) +@cindex GetCWD intrinsic +@cindex intrinsics, GetCWD + +@noindent +@example +GetCWD(@var{Name}) +@end example + +@noindent +GetCWD: @code{INTEGER(KIND=1)} function. + +@noindent +@var{Name}: @code{CHARACTER}; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Places the current working directory in @var{Name}. +Returns 0 on +success, otherwise a non-zero error code +(@code{ENOSYS} if the system does not provide @code{getcwd(3)} +or @code{getwd(3)}). + +For information on other intrinsics with the same name: +@xref{GetCWD Intrinsic (subroutine)}. + +@node GetEnv Intrinsic +@subsubsection GetEnv Intrinsic +@cindex GetEnv intrinsic +@cindex intrinsics, GetEnv + +@noindent +@example +CALL GetEnv(@var{Name}, @var{Value}) +@end example + +@noindent +@var{Name}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Value}: @code{CHARACTER}; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Sets @var{Value} to the value of environment variable given by the +value of @var{Name} (@code{$name} in shell terms) or to blanks if +@code{$name} has not been set. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{Name}---otherwise, +trailing blanks in @var{Name} are ignored. + +@node GetGId Intrinsic +@subsubsection GetGId Intrinsic +@cindex GetGId intrinsic +@cindex intrinsics, GetGId + +@noindent +@example +GetGId() +@end example + +@noindent +GetGId: @code{INTEGER(KIND=1)} function. + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the group id for the current process. + +@node GetLog Intrinsic +@subsubsection GetLog Intrinsic +@cindex GetLog intrinsic +@cindex intrinsics, GetLog + +@noindent +@example +CALL GetLog(@var{Login}) +@end example + +@noindent +@var{Login}: @code{CHARACTER}; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the login name for the process in @var{Login}. + +@node GetPId Intrinsic +@subsubsection GetPId Intrinsic +@cindex GetPId intrinsic +@cindex intrinsics, GetPId + +@noindent +@example +GetPId() +@end example + +@noindent +GetPId: @code{INTEGER(KIND=1)} function. + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the process id for the current process. + +@node GetUId Intrinsic +@subsubsection GetUId Intrinsic +@cindex GetUId intrinsic +@cindex intrinsics, GetUId + +@noindent +@example +GetUId() +@end example + +@noindent +GetUId: @code{INTEGER(KIND=1)} function. + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the user id for the current process. + +@node GMTime Intrinsic +@subsubsection GMTime Intrinsic +@cindex GMTime intrinsic +@cindex intrinsics, GMTime + +@noindent +@example +CALL GMTime(@var{STime}, @var{TArray}) +@end example + +@noindent +@var{STime}: @code{INTEGER(KIND=1)}; scalar; INTENT(IN). + +@noindent +@var{TArray}: @code{INTEGER(KIND=1)}; DIMENSION(9); INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Given a system time value @var{STime}, fills @var{TArray} with values +extracted from it appropriate to the GMT time zone using +@code{gmtime(3)}. + +The array elements are as follows: + +@enumerate +@item +Seconds after the minute, range 0--59 or 0--61 to allow for leap +seconds + +@item +Minutes after the hour, range 0--59 + +@item +Hours past midnight, range 0--23 + +@item +Day of month, range 0--31 + +@item +Number of months since January, range 0--12 + +@item +Years since 1900 + +@item +Number of days since Sunday, range 0--6 + +@item +Days since January 1 + +@item +Daylight savings indicator: positive if daylight savings is in effect, +zero if not, and negative if the information isn't available. +@end enumerate + +@node HostNm Intrinsic (subroutine) +@subsubsection HostNm Intrinsic (subroutine) +@cindex HostNm intrinsic +@cindex intrinsics, HostNm + +@noindent +@example +CALL HostNm(@var{Name}, @var{Status}) +@end example + +@noindent +@var{Name}: @code{CHARACTER}; scalar; INTENT(OUT). + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Fills @var{Name} with the system's host name returned by +@code{gethostname(2)}. +If the @var{Status} argument is supplied, it contains +0 on success or a non-zero error code upon return +(@code{ENOSYS} if the system does not provide @code{gethostname(2)}). + +This intrinsic is not available on all systems. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{Status} argument. + +For information on other intrinsics with the same name: +@xref{HostNm Intrinsic (function)}. + +@node HostNm Intrinsic (function) +@subsubsection HostNm Intrinsic (function) +@cindex HostNm intrinsic +@cindex intrinsics, HostNm + +@noindent +@example +HostNm(@var{Name}) +@end example + +@noindent +HostNm: @code{INTEGER(KIND=1)} function. + +@noindent +@var{Name}: @code{CHARACTER}; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Fills @var{Name} with the system's host name returned by +@code{gethostname(2)}, returning 0 on success or a non-zero error code +(@code{ENOSYS} if the system does not provide @code{gethostname(2)}). + +This intrinsic is not available on all systems. + +For information on other intrinsics with the same name: +@xref{HostNm Intrinsic (subroutine)}. + +@end ifset +@ifset familyF90 +@node Huge Intrinsic +@subsubsection Huge Intrinsic +@cindex Huge intrinsic +@cindex intrinsics, Huge + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Huge} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node IAbs Intrinsic +@subsubsection IAbs Intrinsic +@cindex IAbs intrinsic +@cindex intrinsics, IAbs + +@noindent +@example +IAbs(@var{A}) +@end example + +@noindent +IAbs: @code{INTEGER(KIND=1)} function. + +@noindent +@var{A}: @code{INTEGER(KIND=1)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{ABS()} that is specific +to one type for @var{A}. +@xref{Abs Intrinsic}. + +@end ifset +@ifset familyASC +@node IAChar Intrinsic +@subsubsection IAChar Intrinsic +@cindex IAChar intrinsic +@cindex intrinsics, IAChar + +@noindent +@example +IAChar(@var{C}) +@end example + +@noindent +IAChar: @code{INTEGER(KIND=1)} function. + +@noindent +@var{C}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}, @code{f90}. + +@noindent +Description: + +Returns the code for the ASCII character in the +first character position of @var{C}. + +@xref{AChar Intrinsic}, for the inverse of this function. + +@xref{IChar Intrinsic}, for the function corresponding +to the system's native character set. + +@end ifset +@ifset familyMIL +@node IAnd Intrinsic +@subsubsection IAnd Intrinsic +@cindex IAnd intrinsic +@cindex intrinsics, IAnd + +@noindent +@example +IAnd(@var{I}, @var{J}) +@end example + +@noindent +IAnd: @code{INTEGER} function, the exact type being the result of cross-promoting the +types of all the arguments. + +@noindent +@var{I}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{J}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}. + +@noindent +Description: + +Returns value resulting from boolean AND of +pair of bits in each of @var{I} and @var{J}. + +@end ifset +@ifset familyF2U +@node IArgC Intrinsic +@subsubsection IArgC Intrinsic +@cindex IArgC intrinsic +@cindex intrinsics, IArgC + +@noindent +@example +IArgC() +@end example + +@noindent +IArgC: @code{INTEGER(KIND=1)} function. + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the number of command-line arguments. + +This count does not include the specification of the program +name itself. + +@end ifset +@ifset familyMIL +@node IBClr Intrinsic +@subsubsection IBClr Intrinsic +@cindex IBClr intrinsic +@cindex intrinsics, IBClr + +@noindent +@example +IBClr(@var{I}, @var{Pos}) +@end example + +@noindent +IBClr: @code{INTEGER} function, the @samp{KIND=} value of the type being that of argument @var{I}. + +@noindent +@var{I}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Pos}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}. + +@noindent +Description: + +Returns the value of @var{I} with bit @var{Pos} cleared (set to +zero). +@xref{BTest Intrinsic} for information on bit positions. + +@node IBits Intrinsic +@subsubsection IBits Intrinsic +@cindex IBits intrinsic +@cindex intrinsics, IBits + +@noindent +@example +IBits(@var{I}, @var{Pos}, @var{Len}) +@end example + +@noindent +IBits: @code{INTEGER} function, the @samp{KIND=} value of the type being that of argument @var{I}. + +@noindent +@var{I}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Pos}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Len}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}. + +@noindent +Description: + +Extracts a subfield of length @var{Len} from @var{I}, starting from +bit position @var{Pos} and extending left for @var{Len} bits. +The result is right-justified and the remaining bits are zeroed. +The value +of @samp{@var{Pos}+@var{Len}} must be less than or equal to the value +@samp{BIT_SIZE(@var{I})}. +@xref{Bit_Size Intrinsic}. + +@node IBSet Intrinsic +@subsubsection IBSet Intrinsic +@cindex IBSet intrinsic +@cindex intrinsics, IBSet + +@noindent +@example +IBSet(@var{I}, @var{Pos}) +@end example + +@noindent +IBSet: @code{INTEGER} function, the @samp{KIND=} value of the type being that of argument @var{I}. + +@noindent +@var{I}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Pos}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}. + +@noindent +Description: + +Returns the value of @var{I} with bit @var{Pos} set (to one). +@xref{BTest Intrinsic} for information on bit positions. + +@end ifset +@ifset familyF77 +@node IChar Intrinsic +@subsubsection IChar Intrinsic +@cindex IChar intrinsic +@cindex intrinsics, IChar + +@noindent +@example +IChar(@var{C}) +@end example + +@noindent +IChar: @code{INTEGER(KIND=1)} function. + +@noindent +@var{C}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the code for the character in the +first character position of @var{C}. + +Because the system's native character set is used, +the correspondence between character and their codes +is not necessarily the same between GNU Fortran +implementations. + +Note that no intrinsic exists to convert a printable +character string to a numerical value. +For example, there is no intrinsic that, given +the @code{CHARACTER} value @samp{'154'}, returns an +@code{INTEGER} or @code{REAL} value with the value @samp{154}. + +Instead, you can use internal-file I/O to do this kind +of conversion. +For example: + +@smallexample +INTEGER VALUE +CHARACTER*10 STRING +STRING = '154' +READ (STRING, '(I10)'), VALUE +PRINT *, VALUE +END +@end smallexample + +The above program, when run, prints: + +@smallexample + 154 +@end smallexample + +@xref{Char Intrinsic}, for the inverse of the @code{ICHAR} function. + +@xref{IAChar Intrinsic}, for the function corresponding +to the ASCII character set. + +@end ifset +@ifset familyF2U +@node IDate Intrinsic (UNIX) +@subsubsection IDate Intrinsic (UNIX) +@cindex IDate intrinsic +@cindex intrinsics, IDate + +@noindent +@example +CALL IDate(@var{TArray}) +@end example + +@noindent +@var{TArray}: @code{INTEGER(KIND=1)}; DIMENSION(3); INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Fills @var{TArray} with the numerical values at the current local time +of day, month (in the range 1--12), and year in elements 1, 2, and 3, +respectively. +The year has four significant digits. + +For information on other intrinsics with the same name: +@xref{IDate Intrinsic (VXT)}. + +@end ifset +@ifset familyVXT +@node IDate Intrinsic (VXT) +@subsubsection IDate Intrinsic (VXT) +@cindex IDate intrinsic +@cindex intrinsics, IDate + +@noindent +@example +CALL IDate(@var{M}, @var{D}, @var{Y}) +@end example + +@noindent +@var{M}: @code{INTEGER(KIND=1)}; scalar; INTENT(OUT). + +@noindent +@var{D}: @code{INTEGER(KIND=1)}; scalar; INTENT(OUT). + +@noindent +@var{Y}: @code{INTEGER(KIND=1)}; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{vxt}. + +@noindent +Description: + +Returns the numerical values of the current local time. +The month (in the range 1--12) is returned in @var{M}, +the day (in the range 1--7) in @var{D}, +and the year in @var{Y} (in the range 0--99). + +This intrinsic is not recommended, due to the year 2000 approaching. + +For information on other intrinsics with the same name: +@xref{IDate Intrinsic (UNIX)}. + +@end ifset +@ifset familyF77 +@node IDiM Intrinsic +@subsubsection IDiM Intrinsic +@cindex IDiM intrinsic +@cindex intrinsics, IDiM + +@noindent +@example +IDiM(@var{X}, @var{Y}) +@end example + +@noindent +IDiM: @code{INTEGER(KIND=1)} function. + +@noindent +@var{X}: @code{INTEGER(KIND=1)}; scalar; INTENT(IN). + +@noindent +@var{Y}: @code{INTEGER(KIND=1)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{IDIM()} that is specific +to one type for @var{X} and @var{Y}. +@xref{IDiM Intrinsic}. + +@node IDInt Intrinsic +@subsubsection IDInt Intrinsic +@cindex IDInt intrinsic +@cindex intrinsics, IDInt + +@noindent +@example +IDInt(@var{A}) +@end example + +@noindent +IDInt: @code{INTEGER(KIND=1)} function. + +@noindent +@var{A}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{INT()} that is specific +to one type for @var{A}. +@xref{Int Intrinsic}. + +@node IDNInt Intrinsic +@subsubsection IDNInt Intrinsic +@cindex IDNInt intrinsic +@cindex intrinsics, IDNInt + +@noindent +@example +IDNInt(@var{A}) +@end example + +@noindent +IDNInt: @code{INTEGER(KIND=1)} function. + +@noindent +@var{A}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{NINT()} that is specific +to one type for @var{A}. +@xref{NInt Intrinsic}. + +@end ifset +@ifset familyMIL +@node IEOr Intrinsic +@subsubsection IEOr Intrinsic +@cindex IEOr intrinsic +@cindex intrinsics, IEOr + +@noindent +@example +IEOr(@var{I}, @var{J}) +@end example + +@noindent +IEOr: @code{INTEGER} function, the exact type being the result of cross-promoting the +types of all the arguments. + +@noindent +@var{I}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{J}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}. + +@noindent +Description: + +Returns value resulting from boolean exclusive-OR of +pair of bits in each of @var{I} and @var{J}. + +@end ifset +@ifset familyF2U +@node IErrNo Intrinsic +@subsubsection IErrNo Intrinsic +@cindex IErrNo intrinsic +@cindex intrinsics, IErrNo + +@noindent +@example +IErrNo() +@end example + +@noindent +IErrNo: @code{INTEGER(KIND=1)} function. + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the last system error number (corresponding to the C +@code{errno}). + +@end ifset +@ifset familyF77 +@node IFix Intrinsic +@subsubsection IFix Intrinsic +@cindex IFix intrinsic +@cindex intrinsics, IFix + +@noindent +@example +IFix(@var{A}) +@end example + +@noindent +IFix: @code{INTEGER(KIND=1)} function. + +@noindent +@var{A}: @code{REAL(KIND=1)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{INT()} that is specific +to one type for @var{A}. +@xref{Int Intrinsic}. + +@end ifset +@ifset familyVXT +@node IIAbs Intrinsic +@subsubsection IIAbs Intrinsic +@cindex IIAbs intrinsic +@cindex intrinsics, IIAbs + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IIAbs} to use this name for an +external procedure. + +@node IIAnd Intrinsic +@subsubsection IIAnd Intrinsic +@cindex IIAnd intrinsic +@cindex intrinsics, IIAnd + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IIAnd} to use this name for an +external procedure. + +@node IIBClr Intrinsic +@subsubsection IIBClr Intrinsic +@cindex IIBClr intrinsic +@cindex intrinsics, IIBClr + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IIBClr} to use this name for an +external procedure. + +@node IIBits Intrinsic +@subsubsection IIBits Intrinsic +@cindex IIBits intrinsic +@cindex intrinsics, IIBits + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IIBits} to use this name for an +external procedure. + +@node IIBSet Intrinsic +@subsubsection IIBSet Intrinsic +@cindex IIBSet intrinsic +@cindex intrinsics, IIBSet + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IIBSet} to use this name for an +external procedure. + +@node IIDiM Intrinsic +@subsubsection IIDiM Intrinsic +@cindex IIDiM intrinsic +@cindex intrinsics, IIDiM + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IIDiM} to use this name for an +external procedure. + +@node IIDInt Intrinsic +@subsubsection IIDInt Intrinsic +@cindex IIDInt intrinsic +@cindex intrinsics, IIDInt + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IIDInt} to use this name for an +external procedure. + +@node IIDNnt Intrinsic +@subsubsection IIDNnt Intrinsic +@cindex IIDNnt intrinsic +@cindex intrinsics, IIDNnt + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IIDNnt} to use this name for an +external procedure. + +@node IIEOr Intrinsic +@subsubsection IIEOr Intrinsic +@cindex IIEOr intrinsic +@cindex intrinsics, IIEOr + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IIEOr} to use this name for an +external procedure. + +@node IIFix Intrinsic +@subsubsection IIFix Intrinsic +@cindex IIFix intrinsic +@cindex intrinsics, IIFix + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IIFix} to use this name for an +external procedure. + +@node IInt Intrinsic +@subsubsection IInt Intrinsic +@cindex IInt intrinsic +@cindex intrinsics, IInt + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IInt} to use this name for an +external procedure. + +@node IIOr Intrinsic +@subsubsection IIOr Intrinsic +@cindex IIOr intrinsic +@cindex intrinsics, IIOr + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IIOr} to use this name for an +external procedure. + +@node IIQint Intrinsic +@subsubsection IIQint Intrinsic +@cindex IIQint intrinsic +@cindex intrinsics, IIQint + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IIQint} to use this name for an +external procedure. + +@node IIQNnt Intrinsic +@subsubsection IIQNnt Intrinsic +@cindex IIQNnt intrinsic +@cindex intrinsics, IIQNnt + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IIQNnt} to use this name for an +external procedure. + +@node IIShftC Intrinsic +@subsubsection IIShftC Intrinsic +@cindex IIShftC intrinsic +@cindex intrinsics, IIShftC + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IIShftC} to use this name for an +external procedure. + +@node IISign Intrinsic +@subsubsection IISign Intrinsic +@cindex IISign intrinsic +@cindex intrinsics, IISign + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IISign} to use this name for an +external procedure. + +@end ifset +@ifset familyF2C +@node Imag Intrinsic +@subsubsection Imag Intrinsic +@cindex Imag intrinsic +@cindex intrinsics, Imag + +@noindent +@example +Imag(@var{Z}) +@end example + +@noindent +Imag: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{Z}. + +@noindent +@var{Z}: @code{COMPLEX}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}. + +@noindent +Description: + +The imaginary part of @var{Z} is returned, without conversion. + +@emph{Note:} The way to do this in standard Fortran 90 +is @samp{AIMAG(@var{Z})}. +However, when, for example, @var{Z} is @code{DOUBLE COMPLEX}, +@samp{AIMAG(@var{Z})} means something different for some compilers +that are not true Fortran 90 compilers but offer some +extensions standardized by Fortran 90 (such as the +@code{DOUBLE COMPLEX} type, also known as @code{COMPLEX(KIND=2)}). + +The advantage of @code{IMAG()} is that, while not necessarily +more or less portable than @code{AIMAG()}, it is more likely to +cause a compiler that doesn't support it to produce a diagnostic +than generate incorrect code. + +@xref{REAL() and AIMAG() of Complex}, for more information. + +@end ifset +@ifset familyGNU +@node ImagPart Intrinsic +@subsubsection ImagPart Intrinsic +@cindex ImagPart intrinsic +@cindex intrinsics, ImagPart + +@noindent +@example +ImagPart(@var{Z}) +@end example + +@noindent +ImagPart: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{Z}. + +@noindent +@var{Z}: @code{COMPLEX}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{gnu}. + +@noindent +Description: + +The imaginary part of @var{Z} is returned, without conversion. + +@emph{Note:} The way to do this in standard Fortran 90 +is @samp{AIMAG(@var{Z})}. +However, when, for example, @var{Z} is @code{DOUBLE COMPLEX}, +@samp{AIMAG(@var{Z})} means something different for some compilers +that are not true Fortran 90 compilers but offer some +extensions standardized by Fortran 90 (such as the +@code{DOUBLE COMPLEX} type, also known as @code{COMPLEX(KIND=2)}). + +The advantage of @code{IMAGPART()} is that, while not necessarily +more or less portable than @code{AIMAG()}, it is more likely to +cause a compiler that doesn't support it to produce a diagnostic +than generate incorrect code. + +@xref{REAL() and AIMAG() of Complex}, for more information. + +@end ifset +@ifset familyVXT +@node IMax0 Intrinsic +@subsubsection IMax0 Intrinsic +@cindex IMax0 intrinsic +@cindex intrinsics, IMax0 + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IMax0} to use this name for an +external procedure. + +@node IMax1 Intrinsic +@subsubsection IMax1 Intrinsic +@cindex IMax1 intrinsic +@cindex intrinsics, IMax1 + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IMax1} to use this name for an +external procedure. + +@node IMin0 Intrinsic +@subsubsection IMin0 Intrinsic +@cindex IMin0 intrinsic +@cindex intrinsics, IMin0 + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IMin0} to use this name for an +external procedure. + +@node IMin1 Intrinsic +@subsubsection IMin1 Intrinsic +@cindex IMin1 intrinsic +@cindex intrinsics, IMin1 + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IMin1} to use this name for an +external procedure. + +@node IMod Intrinsic +@subsubsection IMod Intrinsic +@cindex IMod intrinsic +@cindex intrinsics, IMod + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IMod} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node Index Intrinsic +@subsubsection Index Intrinsic +@cindex Index intrinsic +@cindex intrinsics, Index + +@noindent +@example +Index(@var{String}, @var{Substring}) +@end example + +@noindent +Index: @code{INTEGER(KIND=1)} function. + +@noindent +@var{String}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Substring}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the position of the start of the first occurrence of string +@var{Substring} as a substring in @var{String}, counting from one. +If @var{Substring} doesn't occur in @var{String}, zero is returned. + +@end ifset +@ifset familyVXT +@node INInt Intrinsic +@subsubsection INInt Intrinsic +@cindex INInt intrinsic +@cindex intrinsics, INInt + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL INInt} to use this name for an +external procedure. + +@node INot Intrinsic +@subsubsection INot Intrinsic +@cindex INot intrinsic +@cindex intrinsics, INot + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL INot} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node Int Intrinsic +@subsubsection Int Intrinsic +@cindex Int intrinsic +@cindex intrinsics, Int + +@noindent +@example +Int(@var{A}) +@end example + +@noindent +Int: @code{INTEGER(KIND=1)} function. + +@noindent +@var{A}: @code{INTEGER}, @code{REAL}, or @code{COMPLEX}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns @var{A} with the fractional portion of its +magnitude truncated and its sign preserved, converted +to type @code{INTEGER(KIND=1)}. + +If @var{A} is type @code{COMPLEX}, its real part is +truncated and converted, and its imaginary part is disregarded. + +@xref{NInt Intrinsic}, for how to convert, rounded to nearest +whole number. + +@xref{AInt Intrinsic}, for how to truncate to whole number +without converting. + +@end ifset +@ifset familyGNU +@node Int2 Intrinsic +@subsubsection Int2 Intrinsic +@cindex Int2 intrinsic +@cindex intrinsics, Int2 + +@noindent +@example +Int2(@var{A}) +@end example + +@noindent +Int2: @code{INTEGER(KIND=6)} function. + +@noindent +@var{A}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{gnu}. + +@noindent +Description: + +Returns @var{A} with the fractional portion of its +magnitude truncated and its sign preserved, converted +to type @code{INTEGER(KIND=6)}. + +If @var{A} is type @code{COMPLEX}, its real part +is truncated and converted, and its imaginary part is disgregarded. + +@xref{Int Intrinsic}. + +The precise meaning of this intrinsic might change +in a future version of the GNU Fortran language, +as more is learned about how it is used. + +@node Int8 Intrinsic +@subsubsection Int8 Intrinsic +@cindex Int8 intrinsic +@cindex intrinsics, Int8 + +@noindent +@example +Int8(@var{A}) +@end example + +@noindent +Int8: @code{INTEGER(KIND=2)} function. + +@noindent +@var{A}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{gnu}. + +@noindent +Description: + +Returns @var{A} with the fractional portion of its +magnitude truncated and its sign preserved, converted +to type @code{INTEGER(KIND=2)}. + +If @var{A} is type @code{COMPLEX}, its real part +is truncated and converted, and its imaginary part is disgregarded. + +@xref{Int Intrinsic}. + +The precise meaning of this intrinsic might change +in a future version of the GNU Fortran language, +as more is learned about how it is used. + +@end ifset +@ifset familyMIL +@node IOr Intrinsic +@subsubsection IOr Intrinsic +@cindex IOr intrinsic +@cindex intrinsics, IOr + +@noindent +@example +IOr(@var{I}, @var{J}) +@end example + +@noindent +IOr: @code{INTEGER} function, the exact type being the result of cross-promoting the +types of all the arguments. + +@noindent +@var{I}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{J}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}. + +@noindent +Description: + +Returns value resulting from boolean OR of +pair of bits in each of @var{I} and @var{J}. + +@end ifset +@ifset familyF2U +@node IRand Intrinsic +@subsubsection IRand Intrinsic +@cindex IRand intrinsic +@cindex intrinsics, IRand + +@noindent +@example +IRand(@var{Flag}) +@end example + +@noindent +IRand: @code{INTEGER(KIND=1)} function. + +@noindent +@var{Flag}: @code{INTEGER}; OPTIONAL; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns a uniform quasi-random number up to a system-dependent limit. +If @var{Flag} is 0, the next number in sequence is returned; if +@var{Flag} is 1, the generator is restarted by calling the UNIX function +@samp{srand(0)}; if @var{Flag} has any other value, +it is used as a new seed with @code{srand()}. + +@xref{SRand Intrinsic}. + +@emph{Note:} As typically implemented (by the routine of the same +name in the C library), this random number generator is a very poor +one, though the BSD and GNU libraries provide a much better +implementation than the `traditional' one. +On a different system you almost certainly want to use something better. + +@node IsaTty Intrinsic +@subsubsection IsaTty Intrinsic +@cindex IsaTty intrinsic +@cindex intrinsics, IsaTty + +@noindent +@example +IsaTty(@var{Unit}) +@end example + +@noindent +IsaTty: @code{LOGICAL(KIND=1)} function. + +@noindent +@var{Unit}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns @code{.TRUE.} if and only if the Fortran I/O unit +specified by @var{Unit} is connected +to a terminal device. +See @code{isatty(3)}. + +@end ifset +@ifset familyMIL +@node IShft Intrinsic +@subsubsection IShft Intrinsic +@cindex IShft intrinsic +@cindex intrinsics, IShft + +@noindent +@example +IShft(@var{I}, @var{Shift}) +@end example + +@noindent +IShft: @code{INTEGER} function, the @samp{KIND=} value of the type being that of argument @var{I}. + +@noindent +@var{I}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Shift}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}. + +@noindent +Description: + +All bits representing @var{I} are shifted @var{Shift} places. +@samp{@var{Shift}.GT.0} indicates a left shift, @samp{@var{Shift}.EQ.0} +indicates no shift and @samp{@var{Shift}.LT.0} indicates a right shift. +If the absolute value of the shift count is greater than +@samp{BIT_SIZE(@var{I})}, the result is undefined. +Bits shifted out from the left end or the right end, as the case may be, +are lost. +Zeros are shifted in from the opposite end. + +@xref{IShftC Intrinsic} for the circular-shift equivalent. + +@node IShftC Intrinsic +@subsubsection IShftC Intrinsic +@cindex IShftC intrinsic +@cindex intrinsics, IShftC + +@noindent +@example +IShftC(@var{I}, @var{Shift}, @var{Size}) +@end example + +@noindent +IShftC: @code{INTEGER} function, the @samp{KIND=} value of the type being that of argument @var{I}. + +@noindent +@var{I}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Shift}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Size}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}. + +@noindent +Description: + +The rightmost @var{Size} bits of the argument @var{I} +are shifted circularly @var{Shift} +places, i.e.@ the bits shifted out of one end are shifted into +the opposite end. +No bits are lost. +The unshifted bits of the result are the same as +the unshifted bits of @var{I}. +The absolute value of the argument @var{Shift} +must be less than or equal to @var{Size}. +The value of @var{Size} must be greater than or equal to one and less than +or equal to @samp{BIT_SIZE(@var{I})}. + +@xref{IShft Intrinsic} for the logical shift equivalent. + +@end ifset +@ifset familyF77 +@node ISign Intrinsic +@subsubsection ISign Intrinsic +@cindex ISign intrinsic +@cindex intrinsics, ISign + +@noindent +@example +ISign(@var{A}, @var{B}) +@end example + +@noindent +ISign: @code{INTEGER(KIND=1)} function. + +@noindent +@var{A}: @code{INTEGER(KIND=1)}; scalar; INTENT(IN). + +@noindent +@var{B}: @code{INTEGER(KIND=1)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{ISIGN()} that is specific +to one type for @var{A} and @var{B}. +@xref{ISign Intrinsic}. + +@end ifset +@ifset familyF2U +@node ITime Intrinsic +@subsubsection ITime Intrinsic +@cindex ITime intrinsic +@cindex intrinsics, ITime + +@noindent +@example +CALL ITime(@var{TArray}) +@end example + +@noindent +@var{TArray}: @code{INTEGER(KIND=1)}; DIMENSION(3); INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the current local time hour, minutes, and seconds in elements +1, 2, and 3 of @var{TArray}, respectively. + +@end ifset +@ifset familyVXT +@node IZExt Intrinsic +@subsubsection IZExt Intrinsic +@cindex IZExt intrinsic +@cindex intrinsics, IZExt + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL IZExt} to use this name for an +external procedure. + +@node JIAbs Intrinsic +@subsubsection JIAbs Intrinsic +@cindex JIAbs intrinsic +@cindex intrinsics, JIAbs + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JIAbs} to use this name for an +external procedure. + +@node JIAnd Intrinsic +@subsubsection JIAnd Intrinsic +@cindex JIAnd intrinsic +@cindex intrinsics, JIAnd + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JIAnd} to use this name for an +external procedure. + +@node JIBClr Intrinsic +@subsubsection JIBClr Intrinsic +@cindex JIBClr intrinsic +@cindex intrinsics, JIBClr + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JIBClr} to use this name for an +external procedure. + +@node JIBits Intrinsic +@subsubsection JIBits Intrinsic +@cindex JIBits intrinsic +@cindex intrinsics, JIBits + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JIBits} to use this name for an +external procedure. + +@node JIBSet Intrinsic +@subsubsection JIBSet Intrinsic +@cindex JIBSet intrinsic +@cindex intrinsics, JIBSet + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JIBSet} to use this name for an +external procedure. + +@node JIDiM Intrinsic +@subsubsection JIDiM Intrinsic +@cindex JIDiM intrinsic +@cindex intrinsics, JIDiM + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JIDiM} to use this name for an +external procedure. + +@node JIDInt Intrinsic +@subsubsection JIDInt Intrinsic +@cindex JIDInt intrinsic +@cindex intrinsics, JIDInt + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JIDInt} to use this name for an +external procedure. + +@node JIDNnt Intrinsic +@subsubsection JIDNnt Intrinsic +@cindex JIDNnt intrinsic +@cindex intrinsics, JIDNnt + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JIDNnt} to use this name for an +external procedure. + +@node JIEOr Intrinsic +@subsubsection JIEOr Intrinsic +@cindex JIEOr intrinsic +@cindex intrinsics, JIEOr + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JIEOr} to use this name for an +external procedure. + +@node JIFix Intrinsic +@subsubsection JIFix Intrinsic +@cindex JIFix intrinsic +@cindex intrinsics, JIFix + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JIFix} to use this name for an +external procedure. + +@node JInt Intrinsic +@subsubsection JInt Intrinsic +@cindex JInt intrinsic +@cindex intrinsics, JInt + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JInt} to use this name for an +external procedure. + +@node JIOr Intrinsic +@subsubsection JIOr Intrinsic +@cindex JIOr intrinsic +@cindex intrinsics, JIOr + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JIOr} to use this name for an +external procedure. + +@node JIQint Intrinsic +@subsubsection JIQint Intrinsic +@cindex JIQint intrinsic +@cindex intrinsics, JIQint + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JIQint} to use this name for an +external procedure. + +@node JIQNnt Intrinsic +@subsubsection JIQNnt Intrinsic +@cindex JIQNnt intrinsic +@cindex intrinsics, JIQNnt + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JIQNnt} to use this name for an +external procedure. + +@node JIShft Intrinsic +@subsubsection JIShft Intrinsic +@cindex JIShft intrinsic +@cindex intrinsics, JIShft + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JIShft} to use this name for an +external procedure. + +@node JIShftC Intrinsic +@subsubsection JIShftC Intrinsic +@cindex JIShftC intrinsic +@cindex intrinsics, JIShftC + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JIShftC} to use this name for an +external procedure. + +@node JISign Intrinsic +@subsubsection JISign Intrinsic +@cindex JISign intrinsic +@cindex intrinsics, JISign + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JISign} to use this name for an +external procedure. + +@node JMax0 Intrinsic +@subsubsection JMax0 Intrinsic +@cindex JMax0 intrinsic +@cindex intrinsics, JMax0 + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JMax0} to use this name for an +external procedure. + +@node JMax1 Intrinsic +@subsubsection JMax1 Intrinsic +@cindex JMax1 intrinsic +@cindex intrinsics, JMax1 + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JMax1} to use this name for an +external procedure. + +@node JMin0 Intrinsic +@subsubsection JMin0 Intrinsic +@cindex JMin0 intrinsic +@cindex intrinsics, JMin0 + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JMin0} to use this name for an +external procedure. + +@node JMin1 Intrinsic +@subsubsection JMin1 Intrinsic +@cindex JMin1 intrinsic +@cindex intrinsics, JMin1 + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JMin1} to use this name for an +external procedure. + +@node JMod Intrinsic +@subsubsection JMod Intrinsic +@cindex JMod intrinsic +@cindex intrinsics, JMod + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JMod} to use this name for an +external procedure. + +@node JNInt Intrinsic +@subsubsection JNInt Intrinsic +@cindex JNInt intrinsic +@cindex intrinsics, JNInt + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JNInt} to use this name for an +external procedure. + +@node JNot Intrinsic +@subsubsection JNot Intrinsic +@cindex JNot intrinsic +@cindex intrinsics, JNot + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JNot} to use this name for an +external procedure. + +@node JZExt Intrinsic +@subsubsection JZExt Intrinsic +@cindex JZExt intrinsic +@cindex intrinsics, JZExt + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL JZExt} to use this name for an +external procedure. + +@end ifset +@ifset familyF2U +@node Kill Intrinsic (subroutine) +@subsubsection Kill Intrinsic (subroutine) +@cindex Kill intrinsic +@cindex intrinsics, Kill + +@noindent +@example +CALL Kill(@var{Pid}, @var{Signal}, @var{Status}) +@end example + +@noindent +@var{Pid}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Signal}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Sends the signal specified by @var{Signal} to the process @var{Pid}. +If the @var{Status} argument is supplied, it contains +0 on success or a non-zero error code upon return. +See @code{kill(2)}. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{Status} argument. + +For information on other intrinsics with the same name: +@xref{Kill Intrinsic (function)}. + +@end ifset +@ifset familyBADU77 +@node Kill Intrinsic (function) +@subsubsection Kill Intrinsic (function) +@cindex Kill intrinsic +@cindex intrinsics, Kill + +@noindent +@example +Kill(@var{Pid}, @var{Signal}) +@end example + +@noindent +Kill: @code{INTEGER(KIND=1)} function. + +@noindent +@var{Pid}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Signal}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{badu77}. + +@noindent +Description: + +Sends the signal specified by @var{Signal} to the process @var{Pid}. +Returns 0 on success or a non-zero error code. +See @code{kill(2)}. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. + +For information on other intrinsics with the same name: +@xref{Kill Intrinsic (subroutine)}. + +@end ifset +@ifset familyF90 +@node Kind Intrinsic +@subsubsection Kind Intrinsic +@cindex Kind intrinsic +@cindex intrinsics, Kind + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Kind} to use this name for an +external procedure. + +@node LBound Intrinsic +@subsubsection LBound Intrinsic +@cindex LBound intrinsic +@cindex intrinsics, LBound + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL LBound} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node Len Intrinsic +@subsubsection Len Intrinsic +@cindex Len intrinsic +@cindex intrinsics, Len + +@noindent +@example +Len(@var{String}) +@end example + +@noindent +Len: @code{INTEGER(KIND=1)} function. + +@noindent +@var{String}: @code{CHARACTER}; scalar. + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the length of @var{String}. + +If @var{String} is an array, the length of an element +of @var{String} is returned. + +Note that @var{String} need not be defined when this +intrinsic is invoked, since only the length, not +the content, of @var{String} is needed. + +@xref{Bit_Size Intrinsic}, for the function that determines +the size of its argument in bits. + +@end ifset +@ifset familyF90 +@node Len_Trim Intrinsic +@subsubsection Len_Trim Intrinsic +@cindex Len_Trim intrinsic +@cindex intrinsics, Len_Trim + +@noindent +@example +Len_Trim(@var{String}) +@end example + +@noindent +Len_Trim: @code{INTEGER(KIND=1)} function. + +@noindent +@var{String}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f90}. + +@noindent +Description: + +Returns the index of the last non-blank character in @var{String}. +@code{LNBLNK} and @code{LEN_TRIM} are equivalent. + +@end ifset +@ifset familyF77 +@node LGe Intrinsic +@subsubsection LGe Intrinsic +@cindex LGe intrinsic +@cindex intrinsics, LGe + +@noindent +@example +LGe(@var{String_A}, @var{String_B}) +@end example + +@noindent +LGe: @code{LOGICAL(KIND=1)} function. + +@noindent +@var{String_A}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{String_B}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns @samp{.TRUE.} if @samp{@var{String_A}.GE.@var{String_B}}, +@samp{.FALSE.} otherwise. +@var{String_A} and @var{String_B} are interpreted as containing +ASCII character codes. +If either value contains a character not in the ASCII +character set, the result is processor dependent. + +If the @var{String_A} and @var{String_B} are not the same length, +the shorter is compared as if spaces were appended to +it to form a value that has the same length as the longer. + +The lexical comparison intrinsics @code{LGe}, @code{LGt}, +@code{LLe}, and @code{LLt} differ from the corresponding +intrinsic operators @code{.GE.}, @code{.GT.}, +@code{.LE.}, @code{.LT.}. +Because the ASCII collating sequence is assumed, +the following expressions always return @samp{.TRUE.}: + +@smallexample +LGE ('0', ' ') +LGE ('A', '0') +LGE ('a', 'A') +@end smallexample + +The following related expressions do @emph{not} always +return @samp{.TRUE.}, as they are not necessarily evaluated +assuming the arguments use ASCII encoding: + +@smallexample +'0' .GE. ' ' +'A' .GE. '0' +'a' .GE. 'A' +@end smallexample + +The same difference exists +between @code{LGt} and @code{.GT.}; +between @code{LLe} and @code{.LE.}; and +between @code{LLt} and @code{.LT.}. + +@node LGt Intrinsic +@subsubsection LGt Intrinsic +@cindex LGt intrinsic +@cindex intrinsics, LGt + +@noindent +@example +LGt(@var{String_A}, @var{String_B}) +@end example + +@noindent +LGt: @code{LOGICAL(KIND=1)} function. + +@noindent +@var{String_A}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{String_B}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns @samp{.TRUE.} if @samp{@var{String_A}.GT.@var{String_B}}, +@samp{.FALSE.} otherwise. +@var{String_A} and @var{String_B} are interpreted as containing +ASCII character codes. +If either value contains a character not in the ASCII +character set, the result is processor dependent. + +If the @var{String_A} and @var{String_B} are not the same length, +the shorter is compared as if spaces were appended to +it to form a value that has the same length as the longer. + +@xref{LGe Intrinsic}, for information on the distinction +between the @code{LGT} intrinsic and the @code{.GT.} +operator. + +@end ifset +@ifset familyF2U +@node Link Intrinsic (subroutine) +@subsubsection Link Intrinsic (subroutine) +@cindex Link intrinsic +@cindex intrinsics, Link + +@noindent +@example +CALL Link(@var{Path1}, @var{Path2}, @var{Status}) +@end example + +@noindent +@var{Path1}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Path2}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Makes a (hard) link from file @var{Path1} to @var{Path2}. +A null character (@samp{CHAR(0)}) marks the end of +the names in @var{Path1} and @var{Path2}---otherwise, +trailing blanks in @var{Path1} and @var{Path2} are ignored. +If the @var{Status} argument is supplied, it contains +0 on success or a non-zero error code upon return. +See @code{link(2)}. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{Status} argument. + +For information on other intrinsics with the same name: +@xref{Link Intrinsic (function)}. + +@end ifset +@ifset familyBADU77 +@node Link Intrinsic (function) +@subsubsection Link Intrinsic (function) +@cindex Link intrinsic +@cindex intrinsics, Link + +@noindent +@example +Link(@var{Path1}, @var{Path2}) +@end example + +@noindent +Link: @code{INTEGER(KIND=1)} function. + +@noindent +@var{Path1}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Path2}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{badu77}. + +@noindent +Description: + +Makes a (hard) link from file @var{Path1} to @var{Path2}. +A null character (@samp{CHAR(0)}) marks the end of +the names in @var{Path1} and @var{Path2}---otherwise, +trailing blanks in @var{Path1} and @var{Path2} are ignored. +Returns 0 on success or a non-zero error code. +See @code{link(2)}. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. + +For information on other intrinsics with the same name: +@xref{Link Intrinsic (subroutine)}. + +@end ifset +@ifset familyF77 +@node LLe Intrinsic +@subsubsection LLe Intrinsic +@cindex LLe intrinsic +@cindex intrinsics, LLe + +@noindent +@example +LLe(@var{String_A}, @var{String_B}) +@end example + +@noindent +LLe: @code{LOGICAL(KIND=1)} function. + +@noindent +@var{String_A}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{String_B}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns @samp{.TRUE.} if @samp{@var{String_A}.LE.@var{String_B}}, +@samp{.FALSE.} otherwise. +@var{String_A} and @var{String_B} are interpreted as containing +ASCII character codes. +If either value contains a character not in the ASCII +character set, the result is processor dependent. + +If the @var{String_A} and @var{String_B} are not the same length, +the shorter is compared as if spaces were appended to +it to form a value that has the same length as the longer. + +@xref{LGe Intrinsic}, for information on the distinction +between the @code{LLE} intrinsic and the @code{.LE.} +operator. + +@node LLt Intrinsic +@subsubsection LLt Intrinsic +@cindex LLt intrinsic +@cindex intrinsics, LLt + +@noindent +@example +LLt(@var{String_A}, @var{String_B}) +@end example + +@noindent +LLt: @code{LOGICAL(KIND=1)} function. + +@noindent +@var{String_A}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{String_B}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns @samp{.TRUE.} if @samp{@var{String_A}.LT.@var{String_B}}, +@samp{.FALSE.} otherwise. +@var{String_A} and @var{String_B} are interpreted as containing +ASCII character codes. +If either value contains a character not in the ASCII +character set, the result is processor dependent. + +If the @var{String_A} and @var{String_B} are not the same length, +the shorter is compared as if spaces were appended to +it to form a value that has the same length as the longer. + +@xref{LGe Intrinsic}, for information on the distinction +between the @code{LLT} intrinsic and the @code{.LT.} +operator. + +@end ifset +@ifset familyF2U +@node LnBlnk Intrinsic +@subsubsection LnBlnk Intrinsic +@cindex LnBlnk intrinsic +@cindex intrinsics, LnBlnk + +@noindent +@example +LnBlnk(@var{String}) +@end example + +@noindent +LnBlnk: @code{INTEGER(KIND=1)} function. + +@noindent +@var{String}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the index of the last non-blank character in @var{String}. +@code{LNBLNK} and @code{LEN_TRIM} are equivalent. + +@node Loc Intrinsic +@subsubsection Loc Intrinsic +@cindex Loc intrinsic +@cindex intrinsics, Loc + +@noindent +@example +Loc(@var{Entity}) +@end example + +@noindent +Loc: @code{INTEGER(KIND=0)} function. + +@noindent +@var{Entity}: Any type; cannot be a constant or expression. + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +The @code{LOC()} intrinsic works the +same way as the @code{%LOC()} construct. +@xref{%LOC(),,The @code{%LOC()} Construct}, for +more information. + +@end ifset +@ifset familyF77 +@node Log Intrinsic +@subsubsection Log Intrinsic +@cindex Log intrinsic +@cindex intrinsics, Log + +@noindent +@example +Log(@var{X}) +@end example + +@noindent +Log: @code{REAL} or @code{COMPLEX} function, the exact type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL} or @code{COMPLEX}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the natural logarithm of @var{X}, which must +be greater than zero or, if type @code{COMPLEX}, must not +be zero. + +@xref{Exp Intrinsic}, for the inverse of this function. + +@xref{Log10 Intrinsic}, for the base-10 logarithm function. + +@node Log10 Intrinsic +@subsubsection Log10 Intrinsic +@cindex Log10 intrinsic +@cindex intrinsics, Log10 + +@noindent +@example +Log10(@var{X}) +@end example + +@noindent +Log10: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the natural logarithm of @var{X}, which must +be greater than zero or, if type @code{COMPLEX}, must not +be zero. + +The inverse of this function is @samp{10. ** LOG10(@var{X})}. + +@xref{Log Intrinsic}, for the natural logarithm function. + +@end ifset +@ifset familyF90 +@node Logical Intrinsic +@subsubsection Logical Intrinsic +@cindex Logical intrinsic +@cindex intrinsics, Logical + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Logical} to use this name for an +external procedure. + +@end ifset +@ifset familyF2U +@node Long Intrinsic +@subsubsection Long Intrinsic +@cindex Long intrinsic +@cindex intrinsics, Long + +@noindent +@example +Long(@var{A}) +@end example + +@noindent +Long: @code{INTEGER(KIND=1)} function. + +@noindent +@var{A}: @code{INTEGER(KIND=6)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Archaic form of @code{INT()} that is specific +to one type for @var{A}. +@xref{Int Intrinsic}. + +The precise meaning of this intrinsic might change +in a future version of the GNU Fortran language, +as more is learned about how it is used. + +@end ifset +@ifset familyF2C +@node LShift Intrinsic +@subsubsection LShift Intrinsic +@cindex LShift intrinsic +@cindex intrinsics, LShift + +@noindent +@example +LShift(@var{I}, @var{Shift}) +@end example + +@noindent +LShift: @code{INTEGER} function, the @samp{KIND=} value of the type being that of argument @var{I}. + +@noindent +@var{I}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Shift}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}. + +@noindent +Description: + +Returns @var{I} shifted to the left +@var{Shift} bits. + +Although similar to the expression +@samp{@var{I}*(2**@var{Shift})}, there +are important differences. +For example, the sign of the result is +not necessarily the same as the sign of +@var{I}. + +Currently this intrinsic is defined assuming +the underlying representation of @var{I} +is as a two's-complement integer. +It is unclear at this point whether that +definition will apply when a different +representation is involved. + +@xref{LShift Intrinsic}, for the inverse of this function. + +@xref{IShft Intrinsic}, for information +on a more widely available left-shifting +intrinsic that is also more precisely defined. + +@end ifset +@ifset familyF2U +@node LStat Intrinsic (subroutine) +@subsubsection LStat Intrinsic (subroutine) +@cindex LStat intrinsic +@cindex intrinsics, LStat + +@noindent +@example +CALL LStat(@var{File}, @var{SArray}, @var{Status}) +@end example + +@noindent +@var{File}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{SArray}: @code{INTEGER(KIND=1)}; DIMENSION(13); INTENT(OUT). + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Obtains data about the given file @var{File} and places them in the array +@var{SArray}. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{File}---otherwise, +trailing blanks in @var{File} are ignored. +If @var{File} is a symbolic link it returns data on the +link itself, so the routine is available only on systems that support +symbolic links. +The values in this array are extracted from the +@code{stat} structure as returned by @code{fstat(2)} q.v., as follows: + +@enumerate +@item +File mode + +@item +Inode number + +@item +ID of device containing directory entry for file + +@item +Device id (if relevant) + +@item +Number of links + +@item +Owner's uid + +@item +Owner's gid + +@item +File size (bytes) + +@item +Last access time + +@item +Last modification time + +@item +Last file status change time + +@item +Preferred I/O block size + +@item +Number of blocks allocated +@end enumerate + +Not all these elements are relevant on all systems. +If an element is not relevant, it is returned as 0. + +If the @var{Status} argument is supplied, it contains +0 on success or a non-zero error code upon return +(@code{ENOSYS} if the system does not provide @code{lstat(2)}). + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{Status} argument. + +For information on other intrinsics with the same name: +@xref{LStat Intrinsic (function)}. + +@node LStat Intrinsic (function) +@subsubsection LStat Intrinsic (function) +@cindex LStat intrinsic +@cindex intrinsics, LStat + +@noindent +@example +LStat(@var{File}, @var{SArray}) +@end example + +@noindent +LStat: @code{INTEGER(KIND=1)} function. + +@noindent +@var{File}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{SArray}: @code{INTEGER(KIND=1)}; DIMENSION(13); INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Obtains data about the given file @var{File} and places them in the array +@var{SArray}. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{File}---otherwise, +trailing blanks in @var{File} are ignored. +If @var{File} is a symbolic link it returns data on the +link itself, so the routine is available only on systems that support +symbolic links. +The values in this array are extracted from the +@code{stat} structure as returned by @code{fstat(2)} q.v., as follows: + +@enumerate +@item +File mode + +@item +Inode number + +@item +ID of device containing directory entry for file + +@item +Device id (if relevant) + +@item +Number of links + +@item +Owner's uid + +@item +Owner's gid + +@item +File size (bytes) + +@item +Last access time + +@item +Last modification time + +@item +Last file status change time + +@item +Preferred I/O block size + +@item +Number of blocks allocated +@end enumerate + +Not all these elements are relevant on all systems. +If an element is not relevant, it is returned as 0. + +Returns 0 on success or a non-zero error code +(@code{ENOSYS} if the system does not provide @code{lstat(2)}). + +For information on other intrinsics with the same name: +@xref{LStat Intrinsic (subroutine)}. + +@node LTime Intrinsic +@subsubsection LTime Intrinsic +@cindex LTime intrinsic +@cindex intrinsics, LTime + +@noindent +@example +CALL LTime(@var{STime}, @var{TArray}) +@end example + +@noindent +@var{STime}: @code{INTEGER(KIND=1)}; scalar; INTENT(IN). + +@noindent +@var{TArray}: @code{INTEGER(KIND=1)}; DIMENSION(9); INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Given a system time value @var{STime}, fills @var{TArray} with values +extracted from it appropriate to the GMT time zone using +@code{localtime(3)}. + +The array elements are as follows: + +@enumerate +@item +Seconds after the minute, range 0--59 or 0--61 to allow for leap +seconds + +@item +Minutes after the hour, range 0--59 + +@item +Hours past midnight, range 0--23 + +@item +Day of month, range 0--31 + +@item +Number of months since January, range 0--12 + +@item +Years since 1900 + +@item +Number of days since Sunday, range 0--6 + +@item +Days since January 1 + +@item +Daylight savings indicator: positive if daylight savings is in effect, +zero if not, and negative if the information isn't available. +@end enumerate + +@end ifset +@ifset familyF90 +@node MatMul Intrinsic +@subsubsection MatMul Intrinsic +@cindex MatMul intrinsic +@cindex intrinsics, MatMul + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL MatMul} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node Max Intrinsic +@subsubsection Max Intrinsic +@cindex Max intrinsic +@cindex intrinsics, Max + +@noindent +@example +Max(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n) +@end example + +@noindent +Max: @code{INTEGER} or @code{REAL} function, the exact type being the result of cross-promoting the +types of all the arguments. + +@noindent +@var{A}: @code{INTEGER} or @code{REAL}; at least two such arguments must be provided; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the argument with the largest value. + +@xref{Min Intrinsic}, for the opposite function. + +@node Max0 Intrinsic +@subsubsection Max0 Intrinsic +@cindex Max0 intrinsic +@cindex intrinsics, Max0 + +@noindent +@example +Max0(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n) +@end example + +@noindent +Max0: @code{INTEGER(KIND=1)} function. + +@noindent +@var{A}: @code{INTEGER(KIND=1)}; at least two such arguments must be provided; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{MAX()} that is specific +to one type for @var{A}. +@xref{Max Intrinsic}. + +@node Max1 Intrinsic +@subsubsection Max1 Intrinsic +@cindex Max1 intrinsic +@cindex intrinsics, Max1 + +@noindent +@example +Max1(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n) +@end example + +@noindent +Max1: @code{INTEGER(KIND=1)} function. + +@noindent +@var{A}: @code{REAL(KIND=1)}; at least two such arguments must be provided; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{MAX()} that is specific +to one type for @var{A} and a different return type. +@xref{Max Intrinsic}. + +@end ifset +@ifset familyF90 +@node MaxExponent Intrinsic +@subsubsection MaxExponent Intrinsic +@cindex MaxExponent intrinsic +@cindex intrinsics, MaxExponent + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL MaxExponent} to use this name for an +external procedure. + +@node MaxLoc Intrinsic +@subsubsection MaxLoc Intrinsic +@cindex MaxLoc intrinsic +@cindex intrinsics, MaxLoc + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL MaxLoc} to use this name for an +external procedure. + +@node MaxVal Intrinsic +@subsubsection MaxVal Intrinsic +@cindex MaxVal intrinsic +@cindex intrinsics, MaxVal + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL MaxVal} to use this name for an +external procedure. + +@end ifset +@ifset familyF2U +@node MClock Intrinsic +@subsubsection MClock Intrinsic +@cindex MClock intrinsic +@cindex intrinsics, MClock + +@noindent +@example +MClock() +@end example + +@noindent +MClock: @code{INTEGER(KIND=1)} function. + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the number of clock ticks since the start of the process. +Supported on systems with @code{clock(3)} (q.v.). + +This intrinsic is not fully portable, such as to systems +with 32-bit @code{INTEGER} types but supporting times +wider than 32 bits. +@xref{MClock8 Intrinsic}, for information on a +similar intrinsic that might be portable to more +GNU Fortran implementations, though to fewer +Fortran compilers. + +If the system does not support @code{clock(3)}, +-1 is returned. + +@node MClock8 Intrinsic +@subsubsection MClock8 Intrinsic +@cindex MClock8 intrinsic +@cindex intrinsics, MClock8 + +@noindent +@example +MClock8() +@end example + +@noindent +MClock8: @code{INTEGER(KIND=2)} function. + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the number of clock ticks since the start of the process. +Supported on systems with @code{clock(3)} (q.v.). + +No Fortran implementations other than GNU Fortran are +known to support this intrinsic at the time of this +writing. +@xref{MClock Intrinsic}, for information on a +similar intrinsic that might be portable to more Fortran +compilers, though to fewer GNU Fortran implementations. + +If the system does not support @code{clock(3)}, +-1 is returned. + +@end ifset +@ifset familyF90 +@node Merge Intrinsic +@subsubsection Merge Intrinsic +@cindex Merge intrinsic +@cindex intrinsics, Merge + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Merge} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node Min Intrinsic +@subsubsection Min Intrinsic +@cindex Min intrinsic +@cindex intrinsics, Min + +@noindent +@example +Min(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n) +@end example + +@noindent +Min: @code{INTEGER} or @code{REAL} function, the exact type being the result of cross-promoting the +types of all the arguments. + +@noindent +@var{A}: @code{INTEGER} or @code{REAL}; at least two such arguments must be provided; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the argument with the smallest value. + +@xref{Max Intrinsic}, for the opposite function. + +@node Min0 Intrinsic +@subsubsection Min0 Intrinsic +@cindex Min0 intrinsic +@cindex intrinsics, Min0 + +@noindent +@example +Min0(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n) +@end example + +@noindent +Min0: @code{INTEGER(KIND=1)} function. + +@noindent +@var{A}: @code{INTEGER(KIND=1)}; at least two such arguments must be provided; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{MIN()} that is specific +to one type for @var{A}. +@xref{Min Intrinsic}. + +@node Min1 Intrinsic +@subsubsection Min1 Intrinsic +@cindex Min1 intrinsic +@cindex intrinsics, Min1 + +@noindent +@example +Min1(@var{A}-1, @var{A}-2, @dots{}, @var{A}-n) +@end example + +@noindent +Min1: @code{INTEGER(KIND=1)} function. + +@noindent +@var{A}: @code{REAL(KIND=1)}; at least two such arguments must be provided; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{MIN()} that is specific +to one type for @var{A} and a different return type. +@xref{Min Intrinsic}. + +@end ifset +@ifset familyF90 +@node MinExponent Intrinsic +@subsubsection MinExponent Intrinsic +@cindex MinExponent intrinsic +@cindex intrinsics, MinExponent + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL MinExponent} to use this name for an +external procedure. + +@node MinLoc Intrinsic +@subsubsection MinLoc Intrinsic +@cindex MinLoc intrinsic +@cindex intrinsics, MinLoc + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL MinLoc} to use this name for an +external procedure. + +@node MinVal Intrinsic +@subsubsection MinVal Intrinsic +@cindex MinVal intrinsic +@cindex intrinsics, MinVal + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL MinVal} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node Mod Intrinsic +@subsubsection Mod Intrinsic +@cindex Mod intrinsic +@cindex intrinsics, Mod + +@noindent +@example +Mod(@var{A}, @var{P}) +@end example + +@noindent +Mod: @code{INTEGER} or @code{REAL} function, the exact type being the result of cross-promoting the +types of all the arguments. + +@noindent +@var{A}: @code{INTEGER} or @code{REAL}; scalar; INTENT(IN). + +@noindent +@var{P}: @code{INTEGER} or @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns remainder calculated as: + +@smallexample +@var{A} - (INT(@var{A} / @var{P}) * @var{P}) +@end smallexample + +@var{P} must not be zero. + +@end ifset +@ifset familyF90 +@node Modulo Intrinsic +@subsubsection Modulo Intrinsic +@cindex Modulo intrinsic +@cindex intrinsics, Modulo + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Modulo} to use this name for an +external procedure. + +@end ifset +@ifset familyMIL +@node MvBits Intrinsic +@subsubsection MvBits Intrinsic +@cindex MvBits intrinsic +@cindex intrinsics, MvBits + +@noindent +@example +CALL MvBits(@var{From}, @var{FromPos}, @var{Len}, @var{TO}, @var{ToPos}) +@end example + +@noindent +@var{From}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{FromPos}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Len}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{TO}: @code{INTEGER} with same @samp{KIND=} value as for @var{From}; scalar; INTENT(INOUT). + +@noindent +@var{ToPos}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}. + +@noindent +Description: + +Moves @var{Len} bits from positions @var{FromPos} through +@samp{@var{FromPos}+@var{Len}-1} of @var{From} to positions @var{ToPos} through +@samp{@var{FromPos}+@var{Len}-1} of @var{TO}. The portion of argument +@var{TO} not affected by the movement of bits is unchanged. Arguments +@var{From} and @var{TO} are permitted to be the same numeric storage +unit. The values of @samp{@var{FromPos}+@var{Len}} and +@samp{@var{ToPos}+@var{Len}} must be less than or equal to +@samp{BIT_SIZE(@var{From})}. + +@end ifset +@ifset familyF90 +@node Nearest Intrinsic +@subsubsection Nearest Intrinsic +@cindex Nearest intrinsic +@cindex intrinsics, Nearest + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Nearest} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node NInt Intrinsic +@subsubsection NInt Intrinsic +@cindex NInt intrinsic +@cindex intrinsics, NInt + +@noindent +@example +NInt(@var{A}) +@end example + +@noindent +NInt: @code{INTEGER(KIND=1)} function. + +@noindent +@var{A}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns @var{A} with the fractional portion of its +magnitude eliminated by rounding to the nearest whole +number and with its sign preserved, converted +to type @code{INTEGER(KIND=1)}. + +If @var{A} is type @code{COMPLEX}, its real part is +rounded and converted. + +A fractional portion exactly equal to +@samp{.5} is rounded to the whole number that +is larger in magnitude. +(Also called ``Fortran round''.) + +@xref{Int Intrinsic}, for how to convert, truncate to +whole number. + +@xref{ANInt Intrinsic}, for how to round to nearest whole number +without converting. + +@end ifset +@ifset familyMIL +@node Not Intrinsic +@subsubsection Not Intrinsic +@cindex Not intrinsic +@cindex intrinsics, Not + +@noindent +@example +Not(@var{I}) +@end example + +@noindent +Not: @code{INTEGER} function, the @samp{KIND=} value of the type being that of argument @var{I}. + +@noindent +@var{I}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{mil}, @code{f90}, @code{vxt}. + +@noindent +Description: + +Returns value resulting from boolean NOT of each bit +in @var{I}. + +@end ifset +@ifset familyF2C +@node Or Intrinsic +@subsubsection Or Intrinsic +@cindex Or intrinsic +@cindex intrinsics, Or + +@noindent +@example +Or(@var{I}, @var{J}) +@end example + +@noindent +Or: @code{INTEGER} or @code{LOGICAL} function, the exact type being the result of cross-promoting the +types of all the arguments. + +@noindent +@var{I}: @code{INTEGER} or @code{LOGICAL}; scalar; INTENT(IN). + +@noindent +@var{J}: @code{INTEGER} or @code{LOGICAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}. + +@noindent +Description: + +Returns value resulting from boolean OR of +pair of bits in each of @var{I} and @var{J}. + +@end ifset +@ifset familyF90 +@node Pack Intrinsic +@subsubsection Pack Intrinsic +@cindex Pack intrinsic +@cindex intrinsics, Pack + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Pack} to use this name for an +external procedure. + +@end ifset +@ifset familyF2U +@node PError Intrinsic +@subsubsection PError Intrinsic +@cindex PError intrinsic +@cindex intrinsics, PError + +@noindent +@example +CALL PError(@var{String}) +@end example + +@noindent +@var{String}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Prints (on the C @code{stderr} stream) a newline-terminated error +message corresponding to the last system error. +This is prefixed by @var{String}, a colon and a space. +See @code{perror(3)}. + +@end ifset +@ifset familyF90 +@node Precision Intrinsic +@subsubsection Precision Intrinsic +@cindex Precision intrinsic +@cindex intrinsics, Precision + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Precision} to use this name for an +external procedure. + +@node Present Intrinsic +@subsubsection Present Intrinsic +@cindex Present intrinsic +@cindex intrinsics, Present + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Present} to use this name for an +external procedure. + +@node Product Intrinsic +@subsubsection Product Intrinsic +@cindex Product intrinsic +@cindex intrinsics, Product + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Product} to use this name for an +external procedure. + +@end ifset +@ifset familyVXT +@node QAbs Intrinsic +@subsubsection QAbs Intrinsic +@cindex QAbs intrinsic +@cindex intrinsics, QAbs + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QAbs} to use this name for an +external procedure. + +@node QACos Intrinsic +@subsubsection QACos Intrinsic +@cindex QACos intrinsic +@cindex intrinsics, QACos + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QACos} to use this name for an +external procedure. + +@node QACosD Intrinsic +@subsubsection QACosD Intrinsic +@cindex QACosD intrinsic +@cindex intrinsics, QACosD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QACosD} to use this name for an +external procedure. + +@node QASin Intrinsic +@subsubsection QASin Intrinsic +@cindex QASin intrinsic +@cindex intrinsics, QASin + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QASin} to use this name for an +external procedure. + +@node QASinD Intrinsic +@subsubsection QASinD Intrinsic +@cindex QASinD intrinsic +@cindex intrinsics, QASinD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QASinD} to use this name for an +external procedure. + +@node QATan Intrinsic +@subsubsection QATan Intrinsic +@cindex QATan intrinsic +@cindex intrinsics, QATan + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QATan} to use this name for an +external procedure. + +@node QATan2 Intrinsic +@subsubsection QATan2 Intrinsic +@cindex QATan2 intrinsic +@cindex intrinsics, QATan2 + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QATan2} to use this name for an +external procedure. + +@node QATan2D Intrinsic +@subsubsection QATan2D Intrinsic +@cindex QATan2D intrinsic +@cindex intrinsics, QATan2D + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QATan2D} to use this name for an +external procedure. + +@node QATanD Intrinsic +@subsubsection QATanD Intrinsic +@cindex QATanD intrinsic +@cindex intrinsics, QATanD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QATanD} to use this name for an +external procedure. + +@node QCos Intrinsic +@subsubsection QCos Intrinsic +@cindex QCos intrinsic +@cindex intrinsics, QCos + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QCos} to use this name for an +external procedure. + +@node QCosD Intrinsic +@subsubsection QCosD Intrinsic +@cindex QCosD intrinsic +@cindex intrinsics, QCosD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QCosD} to use this name for an +external procedure. + +@node QCosH Intrinsic +@subsubsection QCosH Intrinsic +@cindex QCosH intrinsic +@cindex intrinsics, QCosH + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QCosH} to use this name for an +external procedure. + +@node QDiM Intrinsic +@subsubsection QDiM Intrinsic +@cindex QDiM intrinsic +@cindex intrinsics, QDiM + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QDiM} to use this name for an +external procedure. + +@node QExp Intrinsic +@subsubsection QExp Intrinsic +@cindex QExp intrinsic +@cindex intrinsics, QExp + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QExp} to use this name for an +external procedure. + +@node QExt Intrinsic +@subsubsection QExt Intrinsic +@cindex QExt intrinsic +@cindex intrinsics, QExt + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QExt} to use this name for an +external procedure. + +@node QExtD Intrinsic +@subsubsection QExtD Intrinsic +@cindex QExtD intrinsic +@cindex intrinsics, QExtD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QExtD} to use this name for an +external procedure. + +@node QFloat Intrinsic +@subsubsection QFloat Intrinsic +@cindex QFloat intrinsic +@cindex intrinsics, QFloat + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QFloat} to use this name for an +external procedure. + +@node QInt Intrinsic +@subsubsection QInt Intrinsic +@cindex QInt intrinsic +@cindex intrinsics, QInt + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QInt} to use this name for an +external procedure. + +@node QLog Intrinsic +@subsubsection QLog Intrinsic +@cindex QLog intrinsic +@cindex intrinsics, QLog + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QLog} to use this name for an +external procedure. + +@node QLog10 Intrinsic +@subsubsection QLog10 Intrinsic +@cindex QLog10 intrinsic +@cindex intrinsics, QLog10 + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QLog10} to use this name for an +external procedure. + +@node QMax1 Intrinsic +@subsubsection QMax1 Intrinsic +@cindex QMax1 intrinsic +@cindex intrinsics, QMax1 + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QMax1} to use this name for an +external procedure. + +@node QMin1 Intrinsic +@subsubsection QMin1 Intrinsic +@cindex QMin1 intrinsic +@cindex intrinsics, QMin1 + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QMin1} to use this name for an +external procedure. + +@node QMod Intrinsic +@subsubsection QMod Intrinsic +@cindex QMod intrinsic +@cindex intrinsics, QMod + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QMod} to use this name for an +external procedure. + +@node QNInt Intrinsic +@subsubsection QNInt Intrinsic +@cindex QNInt intrinsic +@cindex intrinsics, QNInt + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QNInt} to use this name for an +external procedure. + +@node QSin Intrinsic +@subsubsection QSin Intrinsic +@cindex QSin intrinsic +@cindex intrinsics, QSin + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QSin} to use this name for an +external procedure. + +@node QSinD Intrinsic +@subsubsection QSinD Intrinsic +@cindex QSinD intrinsic +@cindex intrinsics, QSinD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QSinD} to use this name for an +external procedure. + +@node QSinH Intrinsic +@subsubsection QSinH Intrinsic +@cindex QSinH intrinsic +@cindex intrinsics, QSinH + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QSinH} to use this name for an +external procedure. + +@node QSqRt Intrinsic +@subsubsection QSqRt Intrinsic +@cindex QSqRt intrinsic +@cindex intrinsics, QSqRt + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QSqRt} to use this name for an +external procedure. + +@node QTan Intrinsic +@subsubsection QTan Intrinsic +@cindex QTan intrinsic +@cindex intrinsics, QTan + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QTan} to use this name for an +external procedure. + +@node QTanD Intrinsic +@subsubsection QTanD Intrinsic +@cindex QTanD intrinsic +@cindex intrinsics, QTanD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QTanD} to use this name for an +external procedure. + +@node QTanH Intrinsic +@subsubsection QTanH Intrinsic +@cindex QTanH intrinsic +@cindex intrinsics, QTanH + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL QTanH} to use this name for an +external procedure. + +@end ifset +@ifset familyF90 +@node Radix Intrinsic +@subsubsection Radix Intrinsic +@cindex Radix intrinsic +@cindex intrinsics, Radix + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Radix} to use this name for an +external procedure. + +@end ifset +@ifset familyF2U +@node Rand Intrinsic +@subsubsection Rand Intrinsic +@cindex Rand intrinsic +@cindex intrinsics, Rand + +@noindent +@example +Rand(@var{Flag}) +@end example + +@noindent +Rand: @code{REAL(KIND=1)} function. + +@noindent +@var{Flag}: @code{INTEGER}; OPTIONAL; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns a uniform quasi-random number between 0 and 1. +If @var{Flag} is 0, the next number in sequence is returned; if +@var{Flag} is 1, the generator is restarted by calling @samp{srand(0)}; +if @var{Flag} has any other value, it is used as a new seed with +@code{srand}. + +@xref{SRand Intrinsic}. + +@emph{Note:} As typically implemented (by the routine of the same +name in the C library), this random number generator is a very poor +one, though the BSD and GNU libraries provide a much better +implementation than the `traditional' one. +On a different system you +almost certainly want to use something better. + +@end ifset +@ifset familyF90 +@node Random_Number Intrinsic +@subsubsection Random_Number Intrinsic +@cindex Random_Number intrinsic +@cindex intrinsics, Random_Number + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Random_Number} to use this name for an +external procedure. + +@node Random_Seed Intrinsic +@subsubsection Random_Seed Intrinsic +@cindex Random_Seed intrinsic +@cindex intrinsics, Random_Seed + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Random_Seed} to use this name for an +external procedure. + +@node Range Intrinsic +@subsubsection Range Intrinsic +@cindex Range intrinsic +@cindex intrinsics, Range + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Range} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node Real Intrinsic +@subsubsection Real Intrinsic +@cindex Real intrinsic +@cindex intrinsics, Real + +@noindent +@example +Real(@var{A}) +@end example + +@noindent +Real: @code{REAL} function. +The exact type is @samp{REAL(KIND=1)} when argument @var{A} is +any type other than @code{COMPLEX}, or when it is @code{COMPLEX(KIND=1)}. +When @var{A} is any @code{COMPLEX} type other than @code{COMPLEX(KIND=1)}, +this intrinsic is valid only when used as the argument to +@code{REAL()}, as explained below. + +@noindent +@var{A}: @code{INTEGER}, @code{REAL}, or @code{COMPLEX}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Converts @var{A} to @code{REAL(KIND=1)}. + +Use of @code{REAL()} with a @code{COMPLEX} argument +(other than @code{COMPLEX(KIND=1)}) is restricted to the following case: + +@example +REAL(REAL(A)) +@end example + +@noindent +This expression converts the real part of A to +@code{REAL(KIND=1)}. + +@xref{RealPart Intrinsic}, for information on a GNU Fortran +intrinsic that extracts the real part of an arbitrary +@code{COMPLEX} value. + +@xref{REAL() and AIMAG() of Complex}, for more information. + +@end ifset +@ifset familyGNU +@node RealPart Intrinsic +@subsubsection RealPart Intrinsic +@cindex RealPart intrinsic +@cindex intrinsics, RealPart + +@noindent +@example +RealPart(@var{Z}) +@end example + +@noindent +RealPart: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{Z}. + +@noindent +@var{Z}: @code{COMPLEX}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{gnu}. + +@noindent +Description: + +The real part of @var{Z} is returned, without conversion. + +@emph{Note:} The way to do this in standard Fortran 90 +is @samp{REAL(@var{Z})}. +However, when, for example, @var{Z} is @code{COMPLEX(KIND=2)}, +@samp{REAL(@var{Z})} means something different for some compilers +that are not true Fortran 90 compilers but offer some +extensions standardized by Fortran 90 (such as the +@code{DOUBLE COMPLEX} type, also known as @code{COMPLEX(KIND=2)}). + +The advantage of @code{REALPART()} is that, while not necessarily +more or less portable than @code{REAL()}, it is more likely to +cause a compiler that doesn't support it to produce a diagnostic +than generate incorrect code. + +@xref{REAL() and AIMAG() of Complex}, for more information. + +@end ifset +@ifset familyF2U +@node Rename Intrinsic (subroutine) +@subsubsection Rename Intrinsic (subroutine) +@cindex Rename intrinsic +@cindex intrinsics, Rename + +@noindent +@example +CALL Rename(@var{Path1}, @var{Path2}, @var{Status}) +@end example + +@noindent +@var{Path1}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Path2}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Renames the file @var{Path1} to @var{Path2}. +A null character (@samp{CHAR(0)}) marks the end of +the names in @var{Path1} and @var{Path2}---otherwise, +trailing blanks in @var{Path1} and @var{Path2} are ignored. +See @code{rename(2)}. +If the @var{Status} argument is supplied, it contains +0 on success or a non-zero error code upon return. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{Status} argument. + +For information on other intrinsics with the same name: +@xref{Rename Intrinsic (function)}. + +@end ifset +@ifset familyBADU77 +@node Rename Intrinsic (function) +@subsubsection Rename Intrinsic (function) +@cindex Rename intrinsic +@cindex intrinsics, Rename + +@noindent +@example +Rename(@var{Path1}, @var{Path2}) +@end example + +@noindent +Rename: @code{INTEGER(KIND=1)} function. + +@noindent +@var{Path1}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Path2}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{badu77}. + +@noindent +Description: + +Renames the file @var{Path1} to @var{Path2}. +A null character (@samp{CHAR(0)}) marks the end of +the names in @var{Path1} and @var{Path2}---otherwise, +trailing blanks in @var{Path1} and @var{Path2} are ignored. +See @code{rename(2)}. +Returns 0 on success or a non-zero error code. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. + +For information on other intrinsics with the same name: +@xref{Rename Intrinsic (subroutine)}. + +@end ifset +@ifset familyF90 +@node Repeat Intrinsic +@subsubsection Repeat Intrinsic +@cindex Repeat intrinsic +@cindex intrinsics, Repeat + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Repeat} to use this name for an +external procedure. + +@node Reshape Intrinsic +@subsubsection Reshape Intrinsic +@cindex Reshape intrinsic +@cindex intrinsics, Reshape + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Reshape} to use this name for an +external procedure. + +@node RRSpacing Intrinsic +@subsubsection RRSpacing Intrinsic +@cindex RRSpacing intrinsic +@cindex intrinsics, RRSpacing + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL RRSpacing} to use this name for an +external procedure. + +@end ifset +@ifset familyF2C +@node RShift Intrinsic +@subsubsection RShift Intrinsic +@cindex RShift intrinsic +@cindex intrinsics, RShift + +@noindent +@example +RShift(@var{I}, @var{Shift}) +@end example + +@noindent +RShift: @code{INTEGER} function, the @samp{KIND=} value of the type being that of argument @var{I}. + +@noindent +@var{I}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Shift}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}. + +@noindent +Description: + +Returns @var{I} shifted to the right +@var{Shift} bits. + +Although similar to the expression +@samp{@var{I}/(2**@var{Shift})}, there +are important differences. +For example, the sign of the result is +undefined. + +Currently this intrinsic is defined assuming +the underlying representation of @var{I} +is as a two's-complement integer. +It is unclear at this point whether that +definition will apply when a different +representation is involved. + +@xref{RShift Intrinsic}, for the inverse of this function. + +@xref{IShft Intrinsic}, for information +on a more widely available right-shifting +intrinsic that is also more precisely defined. + +@end ifset +@ifset familyF90 +@node Scale Intrinsic +@subsubsection Scale Intrinsic +@cindex Scale intrinsic +@cindex intrinsics, Scale + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Scale} to use this name for an +external procedure. + +@node Scan Intrinsic +@subsubsection Scan Intrinsic +@cindex Scan intrinsic +@cindex intrinsics, Scan + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Scan} to use this name for an +external procedure. + +@end ifset +@ifset familyVXT +@node Secnds Intrinsic +@subsubsection Secnds Intrinsic +@cindex Secnds intrinsic +@cindex intrinsics, Secnds + +@noindent +@example +Secnds(@var{T}) +@end example + +@noindent +Secnds: @code{REAL(KIND=1)} function. + +@noindent +@var{T}: @code{REAL(KIND=1)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{vxt}. + +@noindent +Description: + +Returns the local time in seconds since midnight minus the value +@var{T}. + +@end ifset +@ifset familyF2U +@node Second Intrinsic (function) +@subsubsection Second Intrinsic (function) +@cindex Second intrinsic +@cindex intrinsics, Second + +@noindent +@example +Second() +@end example + +@noindent +Second: @code{REAL(KIND=1)} function. + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the process's runtime in seconds---the same value as the +UNIX function @code{etime} returns. + +This routine is known from Cray Fortran. + +For information on other intrinsics with the same name: +@xref{Second Intrinsic (subroutine)}. + +@node Second Intrinsic (subroutine) +@subsubsection Second Intrinsic (subroutine) +@cindex Second intrinsic +@cindex intrinsics, Second + +@noindent +@example +CALL Second(@var{Seconds}) +@end example + +@noindent +@var{Seconds}: @code{REAL(KIND=1)}; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the process's runtime in seconds in @var{Seconds}---the same value +as the UNIX function @code{etime} returns. + +This routine is known from Cray Fortran. @xref{Cpu_Time Intrinsic} +for a standard equivalent. + +For information on other intrinsics with the same name: +@xref{Second Intrinsic (function)}. + +@end ifset +@ifset familyF90 +@node Selected_Int_Kind Intrinsic +@subsubsection Selected_Int_Kind Intrinsic +@cindex Selected_Int_Kind intrinsic +@cindex intrinsics, Selected_Int_Kind + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Selected_Int_Kind} to use this name for an +external procedure. + +@node Selected_Real_Kind Intrinsic +@subsubsection Selected_Real_Kind Intrinsic +@cindex Selected_Real_Kind intrinsic +@cindex intrinsics, Selected_Real_Kind + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Selected_Real_Kind} to use this name for an +external procedure. + +@node Set_Exponent Intrinsic +@subsubsection Set_Exponent Intrinsic +@cindex Set_Exponent intrinsic +@cindex intrinsics, Set_Exponent + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Set_Exponent} to use this name for an +external procedure. + +@node Shape Intrinsic +@subsubsection Shape Intrinsic +@cindex Shape intrinsic +@cindex intrinsics, Shape + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Shape} to use this name for an +external procedure. + +@end ifset +@ifset familyF2U +@node Short Intrinsic +@subsubsection Short Intrinsic +@cindex Short intrinsic +@cindex intrinsics, Short + +@noindent +@example +Short(@var{A}) +@end example + +@noindent +Short: @code{INTEGER(KIND=6)} function. + +@noindent +@var{A}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns @var{A} with the fractional portion of its +magnitude truncated and its sign preserved, converted +to type @code{INTEGER(KIND=6)}. + +If @var{A} is type @code{COMPLEX}, its real part +is truncated and converted, and its imaginary part is disgregarded. + +@xref{Int Intrinsic}. + +The precise meaning of this intrinsic might change +in a future version of the GNU Fortran language, +as more is learned about how it is used. + +@end ifset +@ifset familyF77 +@node Sign Intrinsic +@subsubsection Sign Intrinsic +@cindex Sign intrinsic +@cindex intrinsics, Sign + +@noindent +@example +Sign(@var{A}, @var{B}) +@end example + +@noindent +Sign: @code{INTEGER} or @code{REAL} function, the exact type being the result of cross-promoting the +types of all the arguments. + +@noindent +@var{A}: @code{INTEGER} or @code{REAL}; scalar; INTENT(IN). + +@noindent +@var{B}: @code{INTEGER} or @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns @samp{ABS(@var{A})*@var{s}}, where +@var{s} is +1 if @samp{@var{B}.GE.0}, +-1 otherwise. + +@xref{Abs Intrinsic}, for the function that returns +the magnitude of a value. + +@end ifset +@ifset familyF2U +@node Signal Intrinsic (subroutine) +@subsubsection Signal Intrinsic (subroutine) +@cindex Signal intrinsic +@cindex intrinsics, Signal + +@noindent +@example +CALL Signal(@var{Number}, @var{Handler}, @var{Status}) +@end example + +@noindent +@var{Number}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Handler}: Signal handler (@code{INTEGER FUNCTION} or @code{SUBROUTINE}) +or dummy/global @code{INTEGER(KIND=1)} scalar. + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +If @var{Handler} is a an @code{EXTERNAL} routine, arranges for it to be +invoked with a single integer argument (of system-dependent length) +when signal @var{Number} occurs. +If @var{Number} is an integer, it can be +used to turn off handling of signal @var{Handler} or revert to its default +action. +See @code{signal(2)}. + +Note that @var{Handler} will be called using C conventions, so its value in +Fortran terms is obtained by applying @code{%LOC()} (or @var{LOC()}) to it. + +The value returned by @code{signal(2)} is written to @var{Status}, if +that argument is supplied. +Otherwise the return value is ignored. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{Status} argument. + +For information on other intrinsics with the same name: +@xref{Signal Intrinsic (function)}. + +@end ifset +@ifset familyBADU77 +@node Signal Intrinsic (function) +@subsubsection Signal Intrinsic (function) +@cindex Signal intrinsic +@cindex intrinsics, Signal + +@noindent +@example +Signal(@var{Number}, @var{Handler}) +@end example + +@noindent +Signal: @code{INTEGER(KIND=1)} function. + +@noindent +@var{Number}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Handler}: Signal handler (@code{INTEGER FUNCTION} or @code{SUBROUTINE}) +or dummy/global @code{INTEGER(KIND=1)} scalar. + +@noindent +Intrinsic groups: @code{badu77}. + +@noindent +Description: + +If @var{Handler} is a an @code{EXTERNAL} routine, arranges for it to be +invoked with a single integer argument (of system-dependent length) +when signal @var{Number} occurs. +If @var{Number} is an integer, it can be +used to turn off handling of signal @var{Handler} or revert to its default +action. +See @code{signal(2)}. + +Note that @var{Handler} will be called using C conventions, so its value in +Fortran terms is obtained by applying @code{%LOC()} (or @var{LOC()}) to it. + +The value returned by @code{signal(2)} is returned. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. + +For information on other intrinsics with the same name: +@xref{Signal Intrinsic (subroutine)}. + +@end ifset +@ifset familyF77 +@node Sin Intrinsic +@subsubsection Sin Intrinsic +@cindex Sin intrinsic +@cindex intrinsics, Sin + +@noindent +@example +Sin(@var{X}) +@end example + +@noindent +Sin: @code{REAL} or @code{COMPLEX} function, the exact type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL} or @code{COMPLEX}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the sine of @var{X}, an angle measured +in radians. + +@xref{ASin Intrinsic}, for the inverse of this function. + +@end ifset +@ifset familyVXT +@node SinD Intrinsic +@subsubsection SinD Intrinsic +@cindex SinD intrinsic +@cindex intrinsics, SinD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL SinD} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node SinH Intrinsic +@subsubsection SinH Intrinsic +@cindex SinH intrinsic +@cindex intrinsics, SinH + +@noindent +@example +SinH(@var{X}) +@end example + +@noindent +SinH: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the hyperbolic sine of @var{X}. + +@end ifset +@ifset familyF2U +@node Sleep Intrinsic +@subsubsection Sleep Intrinsic +@cindex Sleep intrinsic +@cindex intrinsics, Sleep + +@noindent +@example +CALL Sleep(@var{Seconds}) +@end example + +@noindent +@var{Seconds}: @code{INTEGER(KIND=1)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Causes the process to pause for @var{Seconds} seconds. +See @code{sleep(2)}. + +@end ifset +@ifset familyF77 +@node Sngl Intrinsic +@subsubsection Sngl Intrinsic +@cindex Sngl intrinsic +@cindex intrinsics, Sngl + +@noindent +@example +Sngl(@var{A}) +@end example + +@noindent +Sngl: @code{REAL(KIND=1)} function. + +@noindent +@var{A}: @code{REAL(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Archaic form of @code{REAL()} that is specific +to one type for @var{A}. +@xref{Real Intrinsic}. + +@end ifset +@ifset familyVXT +@node SnglQ Intrinsic +@subsubsection SnglQ Intrinsic +@cindex SnglQ intrinsic +@cindex intrinsics, SnglQ + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL SnglQ} to use this name for an +external procedure. + +@end ifset +@ifset familyF90 +@node Spacing Intrinsic +@subsubsection Spacing Intrinsic +@cindex Spacing intrinsic +@cindex intrinsics, Spacing + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Spacing} to use this name for an +external procedure. + +@node Spread Intrinsic +@subsubsection Spread Intrinsic +@cindex Spread intrinsic +@cindex intrinsics, Spread + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Spread} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node SqRt Intrinsic +@subsubsection SqRt Intrinsic +@cindex SqRt intrinsic +@cindex intrinsics, SqRt + +@noindent +@example +SqRt(@var{X}) +@end example + +@noindent +SqRt: @code{REAL} or @code{COMPLEX} function, the exact type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL} or @code{COMPLEX}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the square root of @var{X}, which must +not be negative. + +To calculate and represent the square root of a negative +number, complex arithmetic must be used. +For example, @samp{SQRT(COMPLEX(@var{X}))}. + +The inverse of this function is @samp{SQRT(@var{X}) * SQRT(@var{X})}. + +@end ifset +@ifset familyF2U +@node SRand Intrinsic +@subsubsection SRand Intrinsic +@cindex SRand intrinsic +@cindex intrinsics, SRand + +@noindent +@example +CALL SRand(@var{Seed}) +@end example + +@noindent +@var{Seed}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Reinitialises the generator with the seed in @var{Seed}. +@xref{IRand Intrinsic}. +@xref{Rand Intrinsic}. + +@node Stat Intrinsic (subroutine) +@subsubsection Stat Intrinsic (subroutine) +@cindex Stat intrinsic +@cindex intrinsics, Stat + +@noindent +@example +CALL Stat(@var{File}, @var{SArray}, @var{Status}) +@end example + +@noindent +@var{File}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{SArray}: @code{INTEGER(KIND=1)}; DIMENSION(13); INTENT(OUT). + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Obtains data about the given file @var{File} and places them in the array +@var{SArray}. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{File}---otherwise, +trailing blanks in @var{File} are ignored. +The values in this array are extracted from the +@code{stat} structure as returned by @code{fstat(2)} q.v., as follows: + +@enumerate +@item +File mode + +@item +Inode number + +@item +ID of device containing directory entry for file + +@item +Device id (if relevant) + +@item +Number of links + +@item +Owner's uid + +@item +Owner's gid + +@item +File size (bytes) + +@item +Last access time + +@item +Last modification time + +@item +Last file status change time + +@item +Preferred I/O block size + +@item +Number of blocks allocated +@end enumerate + +Not all these elements are relevant on all systems. +If an element is not relevant, it is returned as 0. + +If the @var{Status} argument is supplied, it contains +0 on success or a non-zero error code upon return. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{Status} argument. + +For information on other intrinsics with the same name: +@xref{Stat Intrinsic (function)}. + +@node Stat Intrinsic (function) +@subsubsection Stat Intrinsic (function) +@cindex Stat intrinsic +@cindex intrinsics, Stat + +@noindent +@example +Stat(@var{File}, @var{SArray}) +@end example + +@noindent +Stat: @code{INTEGER(KIND=1)} function. + +@noindent +@var{File}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{SArray}: @code{INTEGER(KIND=1)}; DIMENSION(13); INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Obtains data about the given file @var{File} and places them in the array +@var{SArray}. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{File}---otherwise, +trailing blanks in @var{File} are ignored. +The values in this array are extracted from the +@code{stat} structure as returned by @code{fstat(2)} q.v., as follows: + +@enumerate +@item +File mode + +@item +Inode number + +@item +ID of device containing directory entry for file + +@item +Device id (if relevant) + +@item +Number of links + +@item +Owner's uid + +@item +Owner's gid + +@item +File size (bytes) + +@item +Last access time + +@item +Last modification time + +@item +Last file status change time + +@item +Preferred I/O block size + +@item +Number of blocks allocated +@end enumerate + +Not all these elements are relevant on all systems. +If an element is not relevant, it is returned as 0. + +Returns 0 on success or a non-zero error code. + +For information on other intrinsics with the same name: +@xref{Stat Intrinsic (subroutine)}. + +@end ifset +@ifset familyF90 +@node Sum Intrinsic +@subsubsection Sum Intrinsic +@cindex Sum intrinsic +@cindex intrinsics, Sum + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Sum} to use this name for an +external procedure. + +@end ifset +@ifset familyF2U +@node SymLnk Intrinsic (subroutine) +@subsubsection SymLnk Intrinsic (subroutine) +@cindex SymLnk intrinsic +@cindex intrinsics, SymLnk + +@noindent +@example +CALL SymLnk(@var{Path1}, @var{Path2}, @var{Status}) +@end example + +@noindent +@var{Path1}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Path2}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Makes a symbolic link from file @var{Path1} to @var{Path2}. +A null character (@samp{CHAR(0)}) marks the end of +the names in @var{Path1} and @var{Path2}---otherwise, +trailing blanks in @var{Path1} and @var{Path2} are ignored. +If the @var{Status} argument is supplied, it contains +0 on success or a non-zero error code upon return +(@code{ENOSYS} if the system does not provide @code{symlink(2)}). + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{Status} argument. + +For information on other intrinsics with the same name: +@xref{SymLnk Intrinsic (function)}. + +@end ifset +@ifset familyBADU77 +@node SymLnk Intrinsic (function) +@subsubsection SymLnk Intrinsic (function) +@cindex SymLnk intrinsic +@cindex intrinsics, SymLnk + +@noindent +@example +SymLnk(@var{Path1}, @var{Path2}) +@end example + +@noindent +SymLnk: @code{INTEGER(KIND=1)} function. + +@noindent +@var{Path1}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Path2}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{badu77}. + +@noindent +Description: + +Makes a symbolic link from file @var{Path1} to @var{Path2}. +A null character (@samp{CHAR(0)}) marks the end of +the names in @var{Path1} and @var{Path2}---otherwise, +trailing blanks in @var{Path1} and @var{Path2} are ignored. +Returns 0 on success or a non-zero error code +(@code{ENOSYS} if the system does not provide @code{symlink(2)}). + +Due to the side effects performed by this intrinsic, the function +form is not recommended. + +For information on other intrinsics with the same name: +@xref{SymLnk Intrinsic (subroutine)}. + +@end ifset +@ifset familyF2U +@node System Intrinsic (subroutine) +@subsubsection System Intrinsic (subroutine) +@cindex System intrinsic +@cindex intrinsics, System + +@noindent +@example +CALL System(@var{Command}, @var{Status}) +@end example + +@noindent +@var{Command}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Passes the command @var{Command} to a shell (see @code{system(3)}). +If argument @var{Status} is present, it contains the value returned by +@code{system(3)}, presumably 0 if the shell command succeeded. +Note that which shell is used to invoke the command is system-dependent +and environment-dependent. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{Status} argument. + +For information on other intrinsics with the same name: +@xref{System Intrinsic (function)}. + +@end ifset +@ifset familyBADU77 +@node System Intrinsic (function) +@subsubsection System Intrinsic (function) +@cindex System intrinsic +@cindex intrinsics, System + +@noindent +@example +System(@var{Command}) +@end example + +@noindent +System: @code{INTEGER(KIND=1)} function. + +@noindent +@var{Command}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{badu77}. + +@noindent +Description: + +Passes the command @var{Command} to a shell (see @code{system(3)}). +Returns the value returned by +@code{system(3)}, presumably 0 if the shell command succeeded. +Note that which shell is used to invoke the command is system-dependent +and environment-dependent. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. +However, the function form can be valid in cases where the +actual side effects performed by the call are unimportant to +the application. + +For example, on a UNIX system, @samp{SAME = SYSTEM('cmp a b')} +does not perform any side effects likely to be important to the +program, so the programmer would not care if the actual system +call (and invocation of @code{cmp}) was optimized away in a situation +where the return value could be determined otherwise, or was not +actually needed (@samp{SAME} not actually referenced after the +sample assignment statement). + +For information on other intrinsics with the same name: +@xref{System Intrinsic (subroutine)}. + +@end ifset +@ifset familyF90 +@node System_Clock Intrinsic +@subsubsection System_Clock Intrinsic +@cindex System_Clock intrinsic +@cindex intrinsics, System_Clock + +@noindent +@example +CALL System_Clock(@var{Count}, @var{Rate}, @var{Max}) +@end example + +@noindent +@var{Count}: @code{INTEGER(KIND=1)}; scalar; INTENT(OUT). + +@noindent +@var{Rate}: @code{INTEGER(KIND=1)}; scalar; INTENT(OUT). + +@noindent +@var{Max}: @code{INTEGER(KIND=1)}; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{f90}. + +@noindent +Description: + +Returns in @var{Count} the current value of the system clock; this is +the value returned by the UNIX function @code{times(2)} +in this implementation, but +isn't in general. +@var{Rate} is the number of clock ticks per second and +@var{Max} is the maximum value this can take, which isn't very useful +in this implementation since it's just the maximum C @code{unsigned +int} value. + +@end ifset +@ifset familyF77 +@node Tan Intrinsic +@subsubsection Tan Intrinsic +@cindex Tan intrinsic +@cindex intrinsics, Tan + +@noindent +@example +Tan(@var{X}) +@end example + +@noindent +Tan: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the tangent of @var{X}, an angle measured +in radians. + +@xref{ATan Intrinsic}, for the inverse of this function. + +@end ifset +@ifset familyVXT +@node TanD Intrinsic +@subsubsection TanD Intrinsic +@cindex TanD intrinsic +@cindex intrinsics, TanD + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL TanD} to use this name for an +external procedure. + +@end ifset +@ifset familyF77 +@node TanH Intrinsic +@subsubsection TanH Intrinsic +@cindex TanH intrinsic +@cindex intrinsics, TanH + +@noindent +@example +TanH(@var{X}) +@end example + +@noindent +TanH: @code{REAL} function, the @samp{KIND=} value of the type being that of argument @var{X}. + +@noindent +@var{X}: @code{REAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: (standard FORTRAN 77). + +@noindent +Description: + +Returns the hyperbolic tangent of @var{X}. + +@end ifset +@ifset familyF2U +@node Time Intrinsic (UNIX) +@subsubsection Time Intrinsic (UNIX) +@cindex Time intrinsic +@cindex intrinsics, Time + +@noindent +@example +Time() +@end example + +@noindent +Time: @code{INTEGER(KIND=1)} function. + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the current time encoded as an integer +(in the manner of the UNIX function @code{time(3)}). +This value is suitable for passing to @code{CTIME}, +@code{GMTIME}, and @code{LTIME}. + +This intrinsic is not fully portable, such as to systems +with 32-bit @code{INTEGER} types but supporting times +wider than 32 bits. +@xref{Time8 Intrinsic}, for information on a +similar intrinsic that might be portable to more +GNU Fortran implementations, though to fewer +Fortran compilers. + +For information on other intrinsics with the same name: +@xref{Time Intrinsic (VXT)}. + +@end ifset +@ifset familyVXT +@node Time Intrinsic (VXT) +@subsubsection Time Intrinsic (VXT) +@cindex Time intrinsic +@cindex intrinsics, Time + +@noindent +@example +CALL Time(@var{Time}) +@end example + +@noindent +@var{Time}: @code{CHARACTER*8}; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{vxt}. + +@noindent +Description: + +Returns in @var{Time} a character representation of the current time as +obtained from @code{ctime(3)}. + +@xref{Fdate Intrinsic (subroutine)} for an equivalent routine. + +For information on other intrinsics with the same name: +@xref{Time Intrinsic (UNIX)}. + +@end ifset +@ifset familyF2U +@node Time8 Intrinsic +@subsubsection Time8 Intrinsic +@cindex Time8 intrinsic +@cindex intrinsics, Time8 + +@noindent +@example +Time8() +@end example + +@noindent +Time8: @code{INTEGER(KIND=2)} function. + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the current time encoded as a long integer +(in the manner of the UNIX function @code{time(3)}). +This value is suitable for passing to @code{CTIME}, +@code{GMTIME}, and @code{LTIME}. + +No Fortran implementations other than GNU Fortran are +known to support this intrinsic at the time of this +writing. +@xref{Time Intrinsic (UNIX)}, for information on a +similar intrinsic that might be portable to more Fortran +compilers, though to fewer GNU Fortran implementations. + +@end ifset +@ifset familyF90 +@node Tiny Intrinsic +@subsubsection Tiny Intrinsic +@cindex Tiny intrinsic +@cindex intrinsics, Tiny + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Tiny} to use this name for an +external procedure. + +@node Transfer Intrinsic +@subsubsection Transfer Intrinsic +@cindex Transfer intrinsic +@cindex intrinsics, Transfer + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Transfer} to use this name for an +external procedure. + +@node Transpose Intrinsic +@subsubsection Transpose Intrinsic +@cindex Transpose intrinsic +@cindex intrinsics, Transpose + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Transpose} to use this name for an +external procedure. + +@node Trim Intrinsic +@subsubsection Trim Intrinsic +@cindex Trim intrinsic +@cindex intrinsics, Trim + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Trim} to use this name for an +external procedure. + +@end ifset +@ifset familyF2U +@node TtyNam Intrinsic (subroutine) +@subsubsection TtyNam Intrinsic (subroutine) +@cindex TtyNam intrinsic +@cindex intrinsics, TtyNam + +@noindent +@example +CALL TtyNam(@var{Name}, @var{Unit}) +@end example + +@noindent +@var{Name}: @code{CHARACTER}; scalar; INTENT(OUT). + +@noindent +@var{Unit}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Sets @var{Name} to the name of the terminal device open on logical unit +@var{Unit} or a blank string if @var{Unit} is not connected to a +terminal. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine. + +For information on other intrinsics with the same name: +@xref{TtyNam Intrinsic (function)}. + +@node TtyNam Intrinsic (function) +@subsubsection TtyNam Intrinsic (function) +@cindex TtyNam intrinsic +@cindex intrinsics, TtyNam + +@noindent +@example +TtyNam(@var{Unit}) +@end example + +@noindent +TtyNam: @code{CHARACTER*(*)} function. + +@noindent +@var{Unit}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Returns the name of the terminal device open on logical unit +@var{Unit} or a blank string if @var{Unit} is not connected to a +terminal. + +For information on other intrinsics with the same name: +@xref{TtyNam Intrinsic (subroutine)}. + +@end ifset +@ifset familyF90 +@node UBound Intrinsic +@subsubsection UBound Intrinsic +@cindex UBound intrinsic +@cindex intrinsics, UBound + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL UBound} to use this name for an +external procedure. + +@end ifset +@ifset familyF2U +@node UMask Intrinsic (subroutine) +@subsubsection UMask Intrinsic (subroutine) +@cindex UMask intrinsic +@cindex intrinsics, UMask + +@noindent +@example +CALL UMask(@var{Mask}, @var{Old}) +@end example + +@noindent +@var{Mask}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +@var{Old}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Sets the file creation mask to @var{Mask} and returns the old value in +argument @var{Old} if it is supplied. +See @code{umask(2)}. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine. + +For information on other intrinsics with the same name: +@xref{UMask Intrinsic (function)}. + +@end ifset +@ifset familyBADU77 +@node UMask Intrinsic (function) +@subsubsection UMask Intrinsic (function) +@cindex UMask intrinsic +@cindex intrinsics, UMask + +@noindent +@example +UMask(@var{Mask}) +@end example + +@noindent +UMask: @code{INTEGER(KIND=1)} function. + +@noindent +@var{Mask}: @code{INTEGER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{badu77}. + +@noindent +Description: + +Sets the file creation mask to @var{Mask} and returns the old value. +See @code{umask(2)}. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. + +For information on other intrinsics with the same name: +@xref{UMask Intrinsic (subroutine)}. + +@end ifset +@ifset familyF2U +@node Unlink Intrinsic (subroutine) +@subsubsection Unlink Intrinsic (subroutine) +@cindex Unlink intrinsic +@cindex intrinsics, Unlink + +@noindent +@example +CALL Unlink(@var{File}, @var{Status}) +@end example + +@noindent +@var{File}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +@var{Status}: @code{INTEGER(KIND=1)}; OPTIONAL; scalar; INTENT(OUT). + +@noindent +Intrinsic groups: @code{unix}. + +@noindent +Description: + +Unlink the file @var{File}. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{File}---otherwise, +trailing blanks in @var{File} are ignored. +If the @var{Status} argument is supplied, it contains +0 on success or a non-zero error code upon return. +See @code{unlink(2)}. + +Some non-GNU implementations of Fortran provide this intrinsic as +only a function, not as a subroutine, or do not support the +(optional) @var{Status} argument. + +For information on other intrinsics with the same name: +@xref{Unlink Intrinsic (function)}. + +@end ifset +@ifset familyBADU77 +@node Unlink Intrinsic (function) +@subsubsection Unlink Intrinsic (function) +@cindex Unlink intrinsic +@cindex intrinsics, Unlink + +@noindent +@example +Unlink(@var{File}) +@end example + +@noindent +Unlink: @code{INTEGER(KIND=1)} function. + +@noindent +@var{File}: @code{CHARACTER}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{badu77}. + +@noindent +Description: + +Unlink the file @var{File}. +A null character (@samp{CHAR(0)}) marks the end of +the name in @var{File}---otherwise, +trailing blanks in @var{File} are ignored. +Returns 0 on success or a non-zero error code. +See @code{unlink(2)}. + +Due to the side effects performed by this intrinsic, the function +form is not recommended. + +For information on other intrinsics with the same name: +@xref{Unlink Intrinsic (subroutine)}. + +@end ifset +@ifset familyF90 +@node Unpack Intrinsic +@subsubsection Unpack Intrinsic +@cindex Unpack intrinsic +@cindex intrinsics, Unpack + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Unpack} to use this name for an +external procedure. + +@node Verify Intrinsic +@subsubsection Verify Intrinsic +@cindex Verify intrinsic +@cindex intrinsics, Verify + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL Verify} to use this name for an +external procedure. + +@end ifset +@ifset familyF2C +@node XOr Intrinsic +@subsubsection XOr Intrinsic +@cindex XOr intrinsic +@cindex intrinsics, XOr + +@noindent +@example +XOr(@var{I}, @var{J}) +@end example + +@noindent +XOr: @code{INTEGER} or @code{LOGICAL} function, the exact type being the result of cross-promoting the +types of all the arguments. + +@noindent +@var{I}: @code{INTEGER} or @code{LOGICAL}; scalar; INTENT(IN). + +@noindent +@var{J}: @code{INTEGER} or @code{LOGICAL}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}. + +@noindent +Description: + +Returns value resulting from boolean exclusive-OR of +pair of bits in each of @var{I} and @var{J}. + +@node ZAbs Intrinsic +@subsubsection ZAbs Intrinsic +@cindex ZAbs intrinsic +@cindex intrinsics, ZAbs + +@noindent +@example +ZAbs(@var{A}) +@end example + +@noindent +ZAbs: @code{REAL(KIND=2)} function. + +@noindent +@var{A}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}. + +@noindent +Description: + +Archaic form of @code{ABS()} that is specific +to one type for @var{A}. +@xref{Abs Intrinsic}. + +@node ZCos Intrinsic +@subsubsection ZCos Intrinsic +@cindex ZCos intrinsic +@cindex intrinsics, ZCos + +@noindent +@example +ZCos(@var{X}) +@end example + +@noindent +ZCos: @code{COMPLEX(KIND=2)} function. + +@noindent +@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}. + +@noindent +Description: + +Archaic form of @code{COS()} that is specific +to one type for @var{X}. +@xref{Cos Intrinsic}. + +@node ZExp Intrinsic +@subsubsection ZExp Intrinsic +@cindex ZExp intrinsic +@cindex intrinsics, ZExp + +@noindent +@example +ZExp(@var{X}) +@end example + +@noindent +ZExp: @code{COMPLEX(KIND=2)} function. + +@noindent +@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}. + +@noindent +Description: + +Archaic form of @code{EXP()} that is specific +to one type for @var{X}. +@xref{Exp Intrinsic}. + +@end ifset +@ifset familyVXT +@node ZExt Intrinsic +@subsubsection ZExt Intrinsic +@cindex ZExt intrinsic +@cindex intrinsics, ZExt + +This intrinsic is not yet implemented. +The name is, however, reserved as an intrinsic. +Use @samp{EXTERNAL ZExt} to use this name for an +external procedure. + +@end ifset +@ifset familyF2C +@node ZLog Intrinsic +@subsubsection ZLog Intrinsic +@cindex ZLog intrinsic +@cindex intrinsics, ZLog + +@noindent +@example +ZLog(@var{X}) +@end example + +@noindent +ZLog: @code{COMPLEX(KIND=2)} function. + +@noindent +@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}. + +@noindent +Description: + +Archaic form of @code{LOG()} that is specific +to one type for @var{X}. +@xref{Log Intrinsic}. + +@node ZSin Intrinsic +@subsubsection ZSin Intrinsic +@cindex ZSin intrinsic +@cindex intrinsics, ZSin + +@noindent +@example +ZSin(@var{X}) +@end example + +@noindent +ZSin: @code{COMPLEX(KIND=2)} function. + +@noindent +@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}. + +@noindent +Description: + +Archaic form of @code{SIN()} that is specific +to one type for @var{X}. +@xref{Sin Intrinsic}. + +@node ZSqRt Intrinsic +@subsubsection ZSqRt Intrinsic +@cindex ZSqRt intrinsic +@cindex intrinsics, ZSqRt + +@noindent +@example +ZSqRt(@var{X}) +@end example + +@noindent +ZSqRt: @code{COMPLEX(KIND=2)} function. + +@noindent +@var{X}: @code{COMPLEX(KIND=2)}; scalar; INTENT(IN). + +@noindent +Intrinsic groups: @code{f2c}. + +@noindent +Description: + +Archaic form of @code{SQRT()} that is specific +to one type for @var{X}. +@xref{SqRt Intrinsic}. + +@end ifset diff --git a/gcc/f/intrin.c b/gcc/f/intrin.c new file mode 100644 index 000000000000..16f36fbdb3c8 --- /dev/null +++ b/gcc/f/intrin.c @@ -0,0 +1,2047 @@ +/* intrin.c -- Recognize references to intrinsics + Copyright (C) 1995-1997 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + +*/ + +#include "proj.h" +#include +#include "intrin.h" +#include "expr.h" +#include "info.h" +#include "src.h" +#include "symbol.h" +#include "target.h" +#include "top.h" + +struct _ffeintrin_name_ + { + char *name_uc; + char *name_lc; + char *name_ic; + ffeintrinGen generic; + ffeintrinSpec specific; + }; + +struct _ffeintrin_gen_ + { + char *name; /* Name as seen in program. */ + ffeintrinSpec specs[2]; + }; + +struct _ffeintrin_spec_ + { + char *name; /* Uppercase name as seen in source code, + lowercase if no source name, "none" if no + name at all (NONE case). */ + bool is_actualarg; /* Ok to pass as actual arg if -pedantic. */ + ffeintrinFamily family; + ffeintrinImp implementation; + }; + +struct _ffeintrin_imp_ + { + char *name; /* Name of implementation. */ +#if FFECOM_targetCURRENT == FFECOM_targetGCC + ffecomGfrt gfrt_direct; /* library routine, direct-callable form. */ + ffecomGfrt gfrt_f2c; /* library routine, f2c-callable form. */ + ffecomGfrt gfrt_gnu; /* library routine, gnu-callable form. */ +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + char *control; + }; + +static ffebad ffeintrin_check_ (ffeintrinImp imp, ffebldOp op, + ffebld args, ffeinfoBasictype *xbt, + ffeinfoKindtype *xkt, + ffetargetCharacterSize *xsz, + bool *check_intrin, + ffelexToken t, + bool commit); +static bool ffeintrin_check_any_ (ffebld arglist); +static int ffeintrin_cmp_name_ (const void *name, const void *intrinsic); + +static struct _ffeintrin_name_ ffeintrin_names_[] += +{ /* Alpha order. */ +#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) \ + { UPPER, LOWER, MIXED, FFEINTRIN_ ## GEN, FFEINTRIN_ ## SPEC }, +#define DEFGEN(CODE,NAME,SPEC1,SPEC2) +#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) +#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) +#include "intrin.def" +#undef DEFNAME +#undef DEFGEN +#undef DEFSPEC +#undef DEFIMP +}; + +static struct _ffeintrin_gen_ ffeintrin_gens_[] += +{ +#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) +#define DEFGEN(CODE,NAME,SPEC1,SPEC2) \ + { NAME, { SPEC1, SPEC2, }, }, +#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) +#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) +#include "intrin.def" +#undef DEFNAME +#undef DEFGEN +#undef DEFSPEC +#undef DEFIMP +}; + +static struct _ffeintrin_imp_ ffeintrin_imps_[] += +{ +#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 }, +#elif FFECOM_targetCURRENT == FFECOM_targetFFE +#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \ + { NAME, CONTROL }, +#else +#error +#endif +#include "intrin.def" +#undef DEFNAME +#undef DEFGEN +#undef DEFSPEC +#undef DEFIMP +}; + +static struct _ffeintrin_spec_ ffeintrin_specs_[] += +{ +#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) +#define DEFGEN(CODE,NAME,SPEC1,SPEC2) +#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) \ + { NAME, CALLABLE, FAMILY, IMP, }, +#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) +#include "intrin.def" +#undef DEFGEN +#undef DEFSPEC +#undef DEFIMP +}; + + +static ffebad +ffeintrin_check_ (ffeintrinImp imp, ffebldOp op, + ffebld args, ffeinfoBasictype *xbt, + ffeinfoKindtype *xkt, + ffetargetCharacterSize *xsz, + bool *check_intrin, + ffelexToken t, + bool commit) +{ + char *c = ffeintrin_imps_[imp].control; + bool subr = (c[0] == '-'); + char *argc; + ffebld arg; + ffeinfoBasictype bt; + ffeinfoKindtype kt; + ffetargetCharacterSize sz = FFETARGET_charactersizeNONE; + ffeinfoKindtype firstarg_kt; + bool need_col; + ffeinfoBasictype col_bt = FFEINFO_basictypeNONE; + ffeinfoKindtype col_kt = FFEINFO_kindtypeNONE; + int colon = (c[2] == ':') ? 2 : 3; + int argno; + + /* Check procedure type (function vs. subroutine) against + invocation. */ + + if (op == FFEBLD_opSUBRREF) + { + if (!subr) + return FFEBAD_INTRINSIC_IS_FUNC; + } + else if (op == FFEBLD_opFUNCREF) + { + if (subr) + return FFEBAD_INTRINSIC_IS_SUBR; + } + else + return FFEBAD_INTRINSIC_REF; + + /* Check the arglist for validity. */ + + if ((args != NULL) + && (ffebld_head (args) != NULL)) + firstarg_kt = ffeinfo_kindtype (ffebld_info (ffebld_head (args))); + else + firstarg_kt = FFEINFO_kindtype; + + for (argc = &c[colon + 3], + arg = args; + *argc != '\0'; + ) + { + char optional = '\0'; + char required = '\0'; + char extra = '\0'; + char basic; + char kind; + int length; + int elements; + bool lastarg_complex = FALSE; + + /* We don't do anything with keywords yet. */ + do + { + } while (*(++argc) != '='); + + ++argc; + if ((*argc == '?') + || (*argc == '!') + || (*argc == '*')) + optional = *(argc++); + if ((*argc == '+') + || (*argc == 'n') + || (*argc == 'p')) + required = *(argc++); + basic = *(argc++); + kind = *(argc++); + if (*argc == '[') + { + length = *++argc - '0'; + if (*++argc != ']') + length = 10 * length + (*(argc++) - '0'); + ++argc; + } + else + length = -1; + if (*argc == '(') + { + elements = *++argc - '0'; + if (*++argc != ')') + elements = 10 * elements + (*(argc++) - '0'); + ++argc; + } + else if (*argc == '&') + { + elements = -1; + ++argc; + } + else + elements = 0; + if ((*argc == '&') + || (*argc == 'i') + || (*argc == 'w') + || (*argc == 'x')) + extra = *(argc++); + if (*argc == ',') + ++argc; + + /* Break out of this loop only when current arg spec completely + processed. */ + + do + { + bool okay; + ffebld a; + ffeinfo i; + bool anynum; + ffeinfoBasictype abt = FFEINFO_basictypeNONE; + ffeinfoKindtype akt = FFEINFO_kindtypeNONE; + + if ((arg == NULL) + || (ffebld_head (arg) == NULL)) + { + if (required != '\0') + return FFEBAD_INTRINSIC_TOOFEW; + if (optional == '\0') + return FFEBAD_INTRINSIC_TOOFEW; + if (arg != NULL) + arg = ffebld_trail (arg); + break; /* Try next argspec. */ + } + + a = ffebld_head (arg); + i = ffebld_info (a); + anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH) + || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS); + + /* See how well the arg matches up to the spec. */ + + switch (basic) + { + case 'A': + okay = (ffeinfo_basictype (i) == FFEINFO_basictypeCHARACTER) + && ((length == -1) + || (ffeinfo_size (i) == (ffetargetCharacterSize) length)); + break; + + case 'C': + okay = anynum + || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX); + abt = FFEINFO_basictypeCOMPLEX; + break; + + case 'I': + okay = anynum + || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER); + abt = FFEINFO_basictypeINTEGER; + break; + + case 'L': + okay = anynum + || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL); + abt = FFEINFO_basictypeLOGICAL; + break; + + case 'R': + okay = anynum + || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL); + abt = FFEINFO_basictypeREAL; + break; + + case 'B': + okay = anynum + || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) + || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL); + break; + + case 'F': + okay = anynum + || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX) + || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL); + break; + + case 'N': + okay = anynum + || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX) + || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) + || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL); + break; + + case 'S': + okay = anynum + || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) + || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL); + break; + + case 'g': + okay = ((ffebld_op (a) == FFEBLD_opLABTER) + || (ffebld_op (a) == FFEBLD_opLABTOK)); + elements = -1; + extra = '-'; + break; + + case 's': + okay = (((((ffeinfo_basictype (i) == FFEINFO_basictypeNONE) + && (ffeinfo_kindtype (i) == FFEINFO_kindtypeNONE) + && (ffeinfo_kind (i) == FFEINFO_kindSUBROUTINE)) + || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) + && (ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGERDEFAULT) + && (ffeinfo_kind (i) == FFEINFO_kindFUNCTION)) + || (ffeinfo_kind (i) == FFEINFO_kindNONE)) + && ((ffeinfo_where (i) == FFEINFO_whereDUMMY) + || (ffeinfo_where (i) == FFEINFO_whereGLOBAL))) + || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) + && (ffeinfo_kind (i) == FFEINFO_kindENTITY))); + elements = -1; + extra = '-'; + break; + + case '-': + default: + okay = TRUE; + break; + } + + switch (kind) + { + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + akt = (kind - '0'); + if ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) + || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL)) + { + switch (akt) + { /* Translate to internal kinds for now! */ + default: + break; + + case 2: + akt = 4; + break; + + case 3: + akt = 2; + break; + + case 4: + akt = 5; + break; + + case 6: + akt = 3; + break; + } + } + okay &= anynum || (ffeinfo_kindtype (i) == akt); + break; + + case 'A': + okay &= anynum || (ffeinfo_kindtype (i) == firstarg_kt); + akt = (firstarg_kt == FFEINFO_kindtype) ? FFEINFO_kindtypeNONE + : firstarg_kt; + break; + + case '*': + default: + break; + } + + switch (elements) + { + ffebld b; + + case -1: + break; + + case 0: + if (ffeinfo_rank (i) != 0) + okay = FALSE; + break; + + default: + if ((ffeinfo_rank (i) != 1) + || (ffebld_op (a) != FFEBLD_opSYMTER) + || ((b = ffesymbol_arraysize (ffebld_symter (a))) == NULL) + || (ffebld_op (b) != FFEBLD_opCONTER) + || (ffeinfo_basictype (ffebld_info (b)) != FFEINFO_basictypeINTEGER) + || (ffeinfo_kindtype (ffebld_info (b)) != FFEINFO_kindtypeINTEGERDEFAULT) + || (ffebld_constant_integer1 (ffebld_conter (b)) != elements)) + okay = FALSE; + break; + } + + switch (extra) + { + case '&': + if ((ffeinfo_kind (i) != FFEINFO_kindENTITY) + || ((ffebld_op (a) != FFEBLD_opSYMTER) + && (ffebld_op (a) != FFEBLD_opSUBSTR) + && (ffebld_op (a) != FFEBLD_opARRAYREF))) + okay = FALSE; + break; + + case 'w': + case 'x': + if ((ffeinfo_kind (i) != FFEINFO_kindENTITY) + || ((ffebld_op (a) != FFEBLD_opSYMTER) + && (ffebld_op (a) != FFEBLD_opARRAYREF) + && (ffebld_op (a) != FFEBLD_opSUBSTR))) + okay = FALSE; + break; + + case '-': + case 'i': + break; + + default: + if (ffeinfo_kind (i) != FFEINFO_kindENTITY) + okay = FALSE; + break; + } + + if ((optional == '!') + && lastarg_complex) + okay = FALSE; + + if (!okay) + { + /* If it wasn't optional, it's an error, + else maybe it could match a later argspec. */ + if (optional == '\0') + return FFEBAD_INTRINSIC_REF; + break; /* Try next argspec. */ + } + + lastarg_complex + = (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX); + + if (anynum) + { + /* If we know dummy arg type, convert to that now. */ + + if ((abt != FFEINFO_basictypeNONE) + && (akt != FFEINFO_kindtypeNONE) + && commit) + { + /* We have a known type, convert hollerith/typeless + to it. */ + + a = ffeexpr_convert (a, t, NULL, + abt, akt, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + ffebld_set_head (arg, a); + } + } + + arg = ffebld_trail (arg); /* Arg accepted, now move on. */ + + if (optional == '*') + continue; /* Go ahead and try another arg. */ + if (required == '\0') + break; + if ((required == 'n') + || (required == '+')) + { + optional = '*'; + required = '\0'; + } + else if (required == 'p') + required = 'n'; + } while (TRUE); + } + + /* Ignore explicit trailing omitted args. */ + + while ((arg != NULL) && (ffebld_head (arg) == NULL)) + arg = ffebld_trail (arg); + + if (arg != NULL) + return FFEBAD_INTRINSIC_TOOMANY; + + /* Set up the initial type for the return value of the function. */ + + need_col = FALSE; + switch (c[0]) + { + case 'A': + bt = FFEINFO_basictypeCHARACTER; + sz = (c[2] == '*') ? FFETARGET_charactersizeNONE : 1; + break; + + case 'C': + bt = FFEINFO_basictypeCOMPLEX; + break; + + case 'I': + bt = FFEINFO_basictypeINTEGER; + break; + + case 'L': + bt = FFEINFO_basictypeLOGICAL; + break; + + case 'R': + bt = FFEINFO_basictypeREAL; + break; + + case 'B': + case 'F': + case 'N': + case 'S': + need_col = TRUE; + /* Fall through. */ + case '-': + default: + bt = FFEINFO_basictypeNONE; + break; + } + + switch (c[1]) + { + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + kt = (c[1] - '0'); + if ((bt == FFEINFO_basictypeINTEGER) + || (bt == FFEINFO_basictypeLOGICAL)) + { + switch (kt) + { /* Translate to internal kinds for now! */ + default: + break; + + case 2: + kt = 4; + break; + + case 3: + kt = 2; + break; + + case 4: + kt = 5; + break; + + case 6: + kt = 3; + break; + } + } + break; + + case 'C': + if (ffe_is_90 ()) + need_col = TRUE; + kt = 1; + break; + + case 'p': + kt = ffecom_pointer_kind (); + break; + + case '=': + need_col = TRUE; + /* Fall through. */ + case '-': + default: + kt = FFEINFO_kindtypeNONE; + break; + } + + /* Determine collective type of COL, if there is one. */ + + if (need_col || c[colon + 1] != '-') + { + bool okay = TRUE; + bool have_anynum = FALSE; + + for (arg = args; + arg != NULL; + arg = (c[colon + 1] == '*') ? ffebld_trail (arg) : NULL) + { + ffebld a = ffebld_head (arg); + ffeinfo i; + bool anynum; + + if (a == NULL) + continue; + i = ffebld_info (a); + + anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH) + || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS); + if (anynum) + { + have_anynum = TRUE; + continue; + } + + if ((col_bt == FFEINFO_basictypeNONE) + && (col_kt == FFEINFO_kindtypeNONE)) + { + col_bt = ffeinfo_basictype (i); + col_kt = ffeinfo_kindtype (i); + } + else + { + ffeexpr_type_combine (&col_bt, &col_kt, + col_bt, col_kt, + ffeinfo_basictype (i), + ffeinfo_kindtype (i), + NULL); + if ((col_bt == FFEINFO_basictypeNONE) + || (col_kt == FFEINFO_kindtypeNONE)) + return FFEBAD_INTRINSIC_REF; + } + } + + if (have_anynum + && ((col_bt == FFEINFO_basictypeNONE) + || (col_kt == FFEINFO_kindtypeNONE))) + { + /* No type, but have hollerith/typeless. Use type of return + value to determine type of COL. */ + + switch (c[0]) + { + case 'A': + return FFEBAD_INTRINSIC_REF; + + case 'B': + case 'I': + case 'L': + if ((col_bt != FFEINFO_basictypeNONE) + && (col_bt != FFEINFO_basictypeINTEGER)) + return FFEBAD_INTRINSIC_REF; + /* Fall through. */ + case 'N': + case 'S': + case '-': + default: + col_bt = FFEINFO_basictypeINTEGER; + col_kt = FFEINFO_kindtypeINTEGER1; + break; + + case 'C': + if ((col_bt != FFEINFO_basictypeNONE) + && (col_bt != FFEINFO_basictypeCOMPLEX)) + return FFEBAD_INTRINSIC_REF; + col_bt = FFEINFO_basictypeCOMPLEX; + col_kt = FFEINFO_kindtypeREAL1; + break; + + case 'R': + if ((col_bt != FFEINFO_basictypeNONE) + && (col_bt != FFEINFO_basictypeREAL)) + return FFEBAD_INTRINSIC_REF; + /* Fall through. */ + case 'F': + col_bt = FFEINFO_basictypeREAL; + col_kt = FFEINFO_kindtypeREAL1; + break; + } + } + + switch (c[0]) + { + case 'B': + okay = (col_bt == FFEINFO_basictypeINTEGER) + || (col_bt == FFEINFO_basictypeLOGICAL); + if (need_col) + bt = col_bt; + break; + + case 'F': + okay = (col_bt == FFEINFO_basictypeCOMPLEX) + || (col_bt == FFEINFO_basictypeREAL); + if (need_col) + bt = col_bt; + break; + + case 'N': + okay = (col_bt == FFEINFO_basictypeCOMPLEX) + || (col_bt == FFEINFO_basictypeINTEGER) + || (col_bt == FFEINFO_basictypeREAL); + if (need_col) + bt = col_bt; + break; + + case 'S': + okay = (col_bt == FFEINFO_basictypeINTEGER) + || (col_bt == FFEINFO_basictypeREAL) + || (col_bt == FFEINFO_basictypeCOMPLEX); + if (need_col) + bt = ((col_bt != FFEINFO_basictypeCOMPLEX) ? col_bt + : FFEINFO_basictypeREAL); + break; + } + + switch (c[1]) + { + case '=': + if (need_col) + kt = col_kt; + break; + + case 'C': + if (col_bt == FFEINFO_basictypeCOMPLEX) + { + if (col_kt != FFEINFO_kindtypeREALDEFAULT) + *check_intrin = TRUE; + if (need_col) + kt = col_kt; + } + break; + } + + if (!okay) + return FFEBAD_INTRINSIC_REF; + } + + /* Now, convert args in the arglist to the final type of the COL. */ + + for (argno = 0, argc = &c[colon + 3], + arg = args; + *argc != '\0'; + ++argno) + { + char optional = '\0'; + char required = '\0'; + char extra = '\0'; + char basic; + char kind; + int length; + int elements; + bool lastarg_complex = FALSE; + + /* We don't do anything with keywords yet. */ + do + { + } while (*(++argc) != '='); + + ++argc; + if ((*argc == '?') + || (*argc == '!') + || (*argc == '*')) + optional = *(argc++); + if ((*argc == '+') + || (*argc == 'n') + || (*argc == 'p')) + required = *(argc++); + basic = *(argc++); + kind = *(argc++); + if (*argc == '[') + { + length = *++argc - '0'; + if (*++argc != ']') + length = 10 * length + (*(argc++) - '0'); + ++argc; + } + else + length = -1; + if (*argc == '(') + { + elements = *++argc - '0'; + if (*++argc != ')') + elements = 10 * elements + (*(argc++) - '0'); + ++argc; + } + else if (*argc == '&') + { + elements = -1; + ++argc; + } + else + elements = 0; + if ((*argc == '&') + || (*argc == 'i') + || (*argc == 'w') + || (*argc == 'x')) + extra = *(argc++); + if (*argc == ',') + ++argc; + + /* Break out of this loop only when current arg spec completely + processed. */ + + do + { + bool okay; + ffebld a; + ffeinfo i; + bool anynum; + ffeinfoBasictype abt = FFEINFO_basictypeNONE; + ffeinfoKindtype akt = FFEINFO_kindtypeNONE; + + if ((arg == NULL) + || (ffebld_head (arg) == NULL)) + { + if (arg != NULL) + arg = ffebld_trail (arg); + break; /* Try next argspec. */ + } + + a = ffebld_head (arg); + i = ffebld_info (a); + anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH) + || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS); + + /* Determine what the default type for anynum would be. */ + + if (anynum) + { + switch (c[colon + 1]) + { + case '-': + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + if (argno != (c[colon + 1] - '0')) + break; + case '*': + abt = col_bt; + akt = col_kt; + break; + } + } + + /* Again, match arg up to the spec. We go through all of + this again to properly follow the contour of optional + arguments. Probably this level of flexibility is not + needed, perhaps it's even downright naughty. */ + + switch (basic) + { + case 'A': + okay = (ffeinfo_basictype (i) == FFEINFO_basictypeCHARACTER) + && ((length == -1) + || (ffeinfo_size (i) == (ffetargetCharacterSize) length)); + break; + + case 'C': + okay = anynum + || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX); + abt = FFEINFO_basictypeCOMPLEX; + break; + + case 'I': + okay = anynum + || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER); + abt = FFEINFO_basictypeINTEGER; + break; + + case 'L': + okay = anynum + || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL); + abt = FFEINFO_basictypeLOGICAL; + break; + + case 'R': + okay = anynum + || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL); + abt = FFEINFO_basictypeREAL; + break; + + case 'B': + okay = anynum + || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) + || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL); + break; + + case 'F': + okay = anynum + || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX) + || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL); + break; + + case 'N': + okay = anynum + || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX) + || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) + || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL); + break; + + case 'S': + okay = anynum + || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) + || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL); + break; + + case 'g': + okay = ((ffebld_op (a) == FFEBLD_opLABTER) + || (ffebld_op (a) == FFEBLD_opLABTOK)); + elements = -1; + extra = '-'; + break; + + case 's': + okay = (((((ffeinfo_basictype (i) == FFEINFO_basictypeNONE) + && (ffeinfo_kindtype (i) == FFEINFO_kindtypeNONE) + && (ffeinfo_kind (i) == FFEINFO_kindSUBROUTINE)) + || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) + && (ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGERDEFAULT) + && (ffeinfo_kind (i) == FFEINFO_kindFUNCTION)) + || (ffeinfo_kind (i) == FFEINFO_kindNONE)) + && ((ffeinfo_where (i) == FFEINFO_whereDUMMY) + || (ffeinfo_where (i) == FFEINFO_whereGLOBAL))) + || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) + && (ffeinfo_kind (i) == FFEINFO_kindENTITY))); + elements = -1; + extra = '-'; + break; + + case '-': + default: + okay = TRUE; + break; + } + + switch (kind) + { + case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + akt = (kind - '0'); + if ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER) + || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL)) + { + switch (akt) + { /* Translate to internal kinds for now! */ + default: + break; + + case 2: + akt = 4; + break; + + case 3: + akt = 2; + break; + + case 4: + akt = 5; + break; + + case 6: + akt = 3; + break; + } + } + okay &= anynum || (ffeinfo_kindtype (i) == akt); + break; + + case 'A': + okay &= anynum || (ffeinfo_kindtype (i) == firstarg_kt); + akt = (firstarg_kt == FFEINFO_kindtype) ? FFEINFO_kindtypeNONE + : firstarg_kt; + break; + + case '*': + default: + break; + } + + switch (elements) + { + ffebld b; + + case -1: + break; + + case 0: + if (ffeinfo_rank (i) != 0) + okay = FALSE; + break; + + default: + if ((ffeinfo_rank (i) != 1) + || (ffebld_op (a) != FFEBLD_opSYMTER) + || ((b = ffesymbol_arraysize (ffebld_symter (a))) == NULL) + || (ffebld_op (b) != FFEBLD_opCONTER) + || (ffeinfo_basictype (ffebld_info (b)) != FFEINFO_basictypeINTEGER) + || (ffeinfo_kindtype (ffebld_info (b)) != FFEINFO_kindtypeINTEGERDEFAULT) + || (ffebld_constant_integer1 (ffebld_conter (b)) != elements)) + okay = FALSE; + break; + } + + switch (extra) + { + case '&': + if ((ffeinfo_kind (i) != FFEINFO_kindENTITY) + || ((ffebld_op (a) != FFEBLD_opSYMTER) + && (ffebld_op (a) != FFEBLD_opSUBSTR) + && (ffebld_op (a) != FFEBLD_opARRAYREF))) + okay = FALSE; + break; + + case 'w': + case 'x': + if ((ffeinfo_kind (i) != FFEINFO_kindENTITY) + || ((ffebld_op (a) != FFEBLD_opSYMTER) + && (ffebld_op (a) != FFEBLD_opARRAYREF) + && (ffebld_op (a) != FFEBLD_opSUBSTR))) + okay = FALSE; + break; + + case '-': + case 'i': + break; + + default: + if (ffeinfo_kind (i) != FFEINFO_kindENTITY) + okay = FALSE; + break; + } + + if ((optional == '!') + && lastarg_complex) + okay = FALSE; + + if (!okay) + { + /* If it wasn't optional, it's an error, + else maybe it could match a later argspec. */ + if (optional == '\0') + return FFEBAD_INTRINSIC_REF; + break; /* Try next argspec. */ + } + + lastarg_complex + = (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX); + + if (anynum && commit) + { + /* If we know dummy arg type, convert to that now. */ + + if (abt == FFEINFO_basictypeNONE) + abt = FFEINFO_basictypeINTEGER; + if (akt == FFEINFO_kindtypeNONE) + akt = FFEINFO_kindtypeINTEGER1; + + /* We have a known type, convert hollerith/typeless to it. */ + + a = ffeexpr_convert (a, t, NULL, + abt, akt, 0, + FFETARGET_charactersizeNONE, + FFEEXPR_contextLET); + ffebld_set_head (arg, a); + } + else if ((c[colon + 1] == '*') && commit) + { + /* This is where we promote types to the consensus + type for the COL. Maybe this is where -fpedantic + should issue a warning as well. */ + + a = ffeexpr_convert (a, t, NULL, + col_bt, col_kt, 0, + ffeinfo_size (i), + FFEEXPR_contextLET); + ffebld_set_head (arg, a); + } + + arg = ffebld_trail (arg); /* Arg accepted, now move on. */ + + if (optional == '*') + continue; /* Go ahead and try another arg. */ + if (required == '\0') + break; + if ((required == 'n') + || (required == '+')) + { + optional = '*'; + required = '\0'; + } + else if (required == 'p') + required = 'n'; + } while (TRUE); + } + + *xbt = bt; + *xkt = kt; + *xsz = sz; + return FFEBAD; +} + +static bool +ffeintrin_check_any_ (ffebld arglist) +{ + ffebld item; + + for (; arglist != NULL; arglist = ffebld_trail (arglist)) + { + item = ffebld_head (arglist); + if ((item != NULL) + && (ffebld_op (item) == FFEBLD_opANY)) + return TRUE; + } + + return FALSE; +} + +/* Compare name to intrinsic's name. Uses strcmp on arguments' names. */ + +static int +ffeintrin_cmp_name_ (const void *name, const void *intrinsic) +{ + char *uc = (char *) ((struct _ffeintrin_name_ *) intrinsic)->name_uc; + char *lc = (char *) ((struct _ffeintrin_name_ *) intrinsic)->name_lc; + char *ic = (char *) ((struct _ffeintrin_name_ *) intrinsic)->name_ic; + + return ffesrc_strcmp_2c (ffe_case_intrin (), name, uc, lc, ic); +} + +/* Return basic type of intrinsic implementation, based on its + run-time implementation *only*. (This is used only when + the type of an intrinsic name is needed without having a + list of arguments, i.e. an interface signature, such as when + passing the intrinsic itself, or really the run-time-library + function, as an argument.) + + If there's no eligible intrinsic implementation, there must be + a bug somewhere else; no such reference should have been permitted + to go this far. (Well, this might be wrong.) */ + +ffeinfoBasictype +ffeintrin_basictype (ffeintrinSpec spec) +{ + ffeintrinImp imp; + ffecomGfrt gfrt; + + assert (spec < FFEINTRIN_spec); + imp = ffeintrin_specs_[spec].implementation; + assert (imp < FFEINTRIN_imp); + + if (ffe_is_f2c ()) + gfrt = ffeintrin_imps_[imp].gfrt_f2c; + else + gfrt = ffeintrin_imps_[imp].gfrt_gnu; + + assert (gfrt != FFECOM_gfrt); + + return ffecom_gfrt_basictype (gfrt); +} + +/* Return family to which specific intrinsic belongs. */ + +ffeintrinFamily +ffeintrin_family (ffeintrinSpec spec) +{ + if (spec >= FFEINTRIN_spec) + return FALSE; + return ffeintrin_specs_[spec].family; +} + +/* Check and fill in info on func/subr ref node. + + ffebld expr; // FUNCREF or SUBRREF with no info (caller + // gets it from the modified info structure). + ffeinfo info; // Already filled in, will be overwritten. + ffelexToken token; // Used for error message. + ffeintrin_fulfill_generic (&expr, &info, token); + + Based on the generic id, figure out which specific procedure is meant and + pick that one. Else return an error, a la _specific. */ + +void +ffeintrin_fulfill_generic (ffebld *expr, ffeinfo *info, ffelexToken t) +{ + ffebld symter; + ffebldOp op; + ffeintrinGen gen; + ffeintrinSpec spec = FFEINTRIN_specNONE; + ffeinfoBasictype bt = FFEINFO_basictypeNONE; + ffeinfoKindtype kt = FFEINFO_kindtypeNONE; + ffetargetCharacterSize sz = FFETARGET_charactersizeNONE; + ffeintrinImp imp; + ffeintrinSpec tspec; + ffeintrinImp nimp = FFEINTRIN_impNONE; + ffebad error; + bool any = FALSE; + bool highly_specific = FALSE; + int i; + + op = ffebld_op (*expr); + assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF)); + assert (ffebld_op (ffebld_left (*expr)) == FFEBLD_opSYMTER); + + gen = ffebld_symter_generic (ffebld_left (*expr)); + assert (gen != FFEINTRIN_genNONE); + + imp = FFEINTRIN_impNONE; + error = FFEBAD; + + any = ffeintrin_check_any_ (ffebld_right (*expr)); + + for (i = 0; + (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs)) + && ((tspec = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE) + && !any; + ++i) + { + ffeintrinImp timp = ffeintrin_specs_[tspec].implementation; + ffeinfoBasictype tbt; + ffeinfoKindtype tkt; + ffetargetCharacterSize tsz; + ffeIntrinsicState state + = ffeintrin_state_family (ffeintrin_specs_[tspec].family); + ffebad terror; + + if (state == FFE_intrinsicstateDELETED) + continue; + + if (timp != FFEINTRIN_impNONE) + { + if (!(ffeintrin_imps_[timp].control[0] == '-') + != !(ffebld_op (*expr) == FFEBLD_opSUBRREF)) + continue; /* Form of reference must match form of specific. */ + } + + if (state == FFE_intrinsicstateDISABLED) + terror = FFEBAD_INTRINSIC_DISABLED; + else if (timp == FFEINTRIN_impNONE) + terror = FFEBAD_INTRINSIC_UNIMPL; + else + { + terror = ffeintrin_check_ (timp, ffebld_op (*expr), + ffebld_right (*expr), + &tbt, &tkt, &tsz, NULL, t, FALSE); + if (terror == FFEBAD) + { + if (imp != FFEINTRIN_impNONE) + { + ffebad_start (FFEBAD_INTRINSIC_AMBIG); + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_string (ffeintrin_gens_[gen].name); + ffebad_string (ffeintrin_specs_[spec].name); + ffebad_string (ffeintrin_specs_[tspec].name); + ffebad_finish (); + } + else + { + if (ffebld_symter_specific (ffebld_left (*expr)) + == tspec) + highly_specific = TRUE; + imp = timp; + spec = tspec; + bt = tbt; + kt = tkt; + sz = tkt; + error = terror; + } + } + else if (terror != FFEBAD) + { /* This error has precedence over others. */ + if ((error == FFEBAD_INTRINSIC_DISABLED) + || (error == FFEBAD_INTRINSIC_UNIMPL)) + error = FFEBAD; + } + } + + if (error == FFEBAD) + error = terror; + } + + if (any || (imp == FFEINTRIN_impNONE)) + { + if (!any) + { + if (error == FFEBAD) + error = FFEBAD_INTRINSIC_REF; + ffebad_start (error); + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_string (ffeintrin_gens_[gen].name); + ffebad_finish (); + } + + *expr = ffebld_new_any (); + *info = ffeinfo_new_any (); + } + else + { + if (!highly_specific && (nimp != FFEINTRIN_impNONE)) + { + fprintf (stderr, "lineno=%ld, gen=%s, imp=%s, timp=%s\n", + (long) lineno, + ffeintrin_gens_[gen].name, + ffeintrin_imps_[imp].name, + ffeintrin_imps_[nimp].name); + assert ("Ambiguous generic reference" == NULL); + abort (); + } + error = ffeintrin_check_ (imp, ffebld_op (*expr), + ffebld_right (*expr), + &bt, &kt, &sz, NULL, t, TRUE); + assert (error == FFEBAD); + *info = ffeinfo_new (bt, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereFLEETING, + sz); + symter = ffebld_left (*expr); + ffebld_symter_set_specific (symter, spec); + ffebld_symter_set_implementation (symter, imp); + ffebld_set_info (symter, + ffeinfo_new (bt, + kt, + 0, + (bt == FFEINFO_basictypeNONE) + ? FFEINFO_kindSUBROUTINE + : FFEINFO_kindFUNCTION, + FFEINFO_whereINTRINSIC, + sz)); + + if ((ffesymbol_attrs (ffebld_symter (symter)) & FFESYMBOL_attrsTYPE) + && (((bt != ffesymbol_basictype (ffebld_symter (symter))) + || (kt != ffesymbol_kindtype (ffebld_symter (symter))) + || (sz != ffesymbol_size (ffebld_symter (symter)))))) + { + ffebad_start (FFEBAD_INTRINSIC_TYPE); + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_string (ffeintrin_gens_[gen].name); + ffebad_finish (); + } + } +} + +/* Check and fill in info on func/subr ref node. + + ffebld expr; // FUNCREF or SUBRREF with no info (caller + // gets it from the modified info structure). + ffeinfo info; // Already filled in, will be overwritten. + bool check_intrin; // May be omitted, else set TRUE if intrinsic needs checking. + ffelexToken token; // Used for error message. + ffeintrin_fulfill_specific (&expr, &info, &check_intrin, token); + + Based on the specific id, determine whether the arg list is valid + (number, type, rank, and kind of args) and fill in the info structure + accordingly. Currently don't rewrite the expression, but perhaps + someday do so for constant collapsing, except when an error occurs, + in which case it is overwritten with ANY and info is also overwritten + accordingly. */ + +void +ffeintrin_fulfill_specific (ffebld *expr, ffeinfo *info, + bool *check_intrin, ffelexToken t) +{ + ffebld symter; + ffebldOp op; + ffeintrinGen gen; + ffeintrinSpec spec; + ffeintrinImp imp; + ffeinfoBasictype bt = FFEINFO_basictypeNONE; + ffeinfoKindtype kt = FFEINFO_kindtypeNONE; + ffetargetCharacterSize sz = FFETARGET_charactersizeNONE; + ffeIntrinsicState state; + ffebad error; + bool any = FALSE; + char *name; + + op = ffebld_op (*expr); + assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF)); + assert (ffebld_op (ffebld_left (*expr)) == FFEBLD_opSYMTER); + + gen = ffebld_symter_generic (ffebld_left (*expr)); + spec = ffebld_symter_specific (ffebld_left (*expr)); + assert (spec != FFEINTRIN_specNONE); + + if (gen != FFEINTRIN_genNONE) + name = ffeintrin_gens_[gen].name; + else + name = ffeintrin_specs_[spec].name; + + state = ffeintrin_state_family (ffeintrin_specs_[spec].family); + + imp = ffeintrin_specs_[spec].implementation; + if (check_intrin != NULL) + *check_intrin = FALSE; + + any = ffeintrin_check_any_ (ffebld_right (*expr)); + + if (state == FFE_intrinsicstateDISABLED) + error = FFEBAD_INTRINSIC_DISABLED; + else if (imp == FFEINTRIN_impNONE) + error = FFEBAD_INTRINSIC_UNIMPL; + else if (!any) + { + error = ffeintrin_check_ (imp, ffebld_op (*expr), + ffebld_right (*expr), + &bt, &kt, &sz, check_intrin, t, TRUE); + } + else + error = FFEBAD; /* Not really needed, but quiet -Wuninitialized. */ + + if (any || (error != FFEBAD)) + { + if (!any) + { + + ffebad_start (error); + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_string (name); + ffebad_finish (); + } + + *expr = ffebld_new_any (); + *info = ffeinfo_new_any (); + } + else + { + *info = ffeinfo_new (bt, + kt, + 0, + FFEINFO_kindENTITY, + FFEINFO_whereFLEETING, + sz); + symter = ffebld_left (*expr); + ffebld_set_info (symter, + ffeinfo_new (bt, + kt, + 0, + (bt == FFEINFO_basictypeNONE) + ? FFEINFO_kindSUBROUTINE + : FFEINFO_kindFUNCTION, + FFEINFO_whereINTRINSIC, + sz)); + + if ((ffesymbol_attrs (ffebld_symter (symter)) & FFESYMBOL_attrsTYPE) + && (((bt != ffesymbol_basictype (ffebld_symter (symter))) + || (kt != ffesymbol_kindtype (ffebld_symter (symter))) + || (sz != ffesymbol_size (ffebld_symter (symter)))))) + { + ffebad_start (FFEBAD_INTRINSIC_TYPE); + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_string (name); + ffebad_finish (); + } + } +} + +/* Return run-time index of intrinsic implementation as direct call. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +ffecomGfrt +ffeintrin_gfrt_direct (ffeintrinImp imp) +{ + assert (imp < FFEINTRIN_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) +{ + assert (imp < FFEINTRIN_imp); + + if (! ffe_is_f2c ()) + return ffeintrin_imps_[imp].gfrt_gnu; + return ffeintrin_imps_[imp].gfrt_f2c; +} +#endif + +void +ffeintrin_init_0 () +{ + int i; + char *p1; + char *p2; + char *p3; + int colon; + + if (!ffe_is_do_internal_checks ()) + return; + + assert (FFEINTRIN_gen == ARRAY_SIZE (ffeintrin_gens_)); + assert (FFEINTRIN_imp == ARRAY_SIZE (ffeintrin_imps_)); + assert (FFEINTRIN_spec == ARRAY_SIZE (ffeintrin_specs_)); + + for (i = 1; ((size_t) i) < ARRAY_SIZE (ffeintrin_names_); ++i) + { /* Make sure binary-searched list is in alpha + order. */ + if (strcmp (ffeintrin_names_[i - 1].name_uc, + ffeintrin_names_[i].name_uc) >= 0) + assert ("name list out of order" == NULL); + } + + for (i = 0; ((size_t) i) < ARRAY_SIZE (ffeintrin_names_); ++i) + { + assert ((ffeintrin_names_[i].generic == FFEINTRIN_genNONE) + || (ffeintrin_names_[i].specific == FFEINTRIN_specNONE)); + + p1 = ffeintrin_names_[i].name_uc; + p2 = ffeintrin_names_[i].name_lc; + p3 = ffeintrin_names_[i].name_ic; + for (; *p1 != '\0' && *p2 != '\0' && *p3 != '\0'; ++p1, ++p2, ++p3) + { + if (!isascii (*p1) || !isascii (*p2) || !isascii (*p3)) + break; + if ((isdigit (*p1) || (*p1 == '_')) && (*p1 == *p2) && (*p1 == *p3)) + continue; + if (!isupper (*p1) || !islower (*p2) + || (*p1 != toupper (*p2)) || ((*p3 != *p1) && (*p3 != *p2))) + break; + } + assert ((*p1 == *p2) && (*p1 == *p3) && (*p1 == '\0')); + } + + for (i = 0; ((size_t) i) < ARRAY_SIZE (ffeintrin_imps_); ++i) + { + char *c = ffeintrin_imps_[i].control; + + if (c[0] == '\0') + continue; + + if ((c[0] != '-') + && (c[0] != 'A') + && (c[0] != 'C') + && (c[0] != 'I') + && (c[0] != 'L') + && (c[0] != 'R') + && (c[0] != 'B') + && (c[0] != 'F') + && (c[0] != 'N') + && (c[0] != 'S')) + { + fprintf (stderr, "%s: bad return-base-type\n", + ffeintrin_imps_[i].name); + continue; + } + if ((c[1] != '-') + && (c[1] != '=') + && ((c[1] < '1') + || (c[1] > '9')) + && (c[1] != 'C') + && (c[1] != 'p')) + { + fprintf (stderr, "%s: bad return-kind-type\n", + ffeintrin_imps_[i].name); + continue; + } + if (c[2] == ':') + colon = 2; + else + { + if (c[2] != '*') + { + fprintf (stderr, "%s: bad return-modifier\n", + ffeintrin_imps_[i].name); + continue; + } + colon = 3; + } + if ((c[colon] != ':') || (c[colon + 2] != ':')) + { + fprintf (stderr, "%s: bad control\n", + ffeintrin_imps_[i].name); + continue; + } + if ((c[colon + 1] != '-') + && (c[colon + 1] != '*') + && ((c[colon + 1] < '0') + || (c[colon + 1] > '9'))) + { + fprintf (stderr, "%s: bad COL-spec\n", + ffeintrin_imps_[i].name); + continue; + } + c += (colon + 3); + while (c[0] != '\0') + { + while ((c[0] != '=') + && (c[0] != ',') + && (c[0] != '\0')) + ++c; + if (c[0] != '=') + { + fprintf (stderr, "%s: bad keyword\n", + ffeintrin_imps_[i].name); + break; + } + if ((c[1] == '?') + || (c[1] == '!') + || (c[1] == '!') + || (c[1] == '+') + || (c[1] == '*') + || (c[1] == 'n') + || (c[1] == 'p')) + ++c; + if (((c[1] != '-') + && (c[1] != 'A') + && (c[1] != 'C') + && (c[1] != 'I') + && (c[1] != 'L') + && (c[1] != 'R') + && (c[1] != 'B') + && (c[1] != 'F') + && (c[1] != 'N') + && (c[1] != 'S') + && (c[1] != 'g') + && (c[1] != 's')) + || ((c[2] != '*') + && ((c[2] < '1') + || (c[2] > '9')) + && (c[2] != 'A'))) + { + fprintf (stderr, "%s: bad arg-type\n", + ffeintrin_imps_[i].name); + break; + } + if (c[3] == '[') + { + if (((c[4] < '0') || (c[4] > '9')) + || ((c[5] != ']') + && (++c, (c[4] < '0') || (c[4] > '9') + || (c[5] != ']')))) + { + fprintf (stderr, "%s: bad arg-len\n", + ffeintrin_imps_[i].name); + break; + } + c += 3; + } + if (c[3] == '(') + { + if (((c[4] < '0') || (c[4] > '9')) + || ((c[5] != ')') + && (++c, (c[4] < '0') || (c[4] > '9') + || (c[5] != ')')))) + { + fprintf (stderr, "%s: bad arg-rank\n", + ffeintrin_imps_[i].name); + break; + } + c += 3; + } + else if ((c[3] == '&') + && (c[4] == '&')) + ++c; + if ((c[3] == '&') + || (c[3] == 'i') + || (c[3] == 'w') + || (c[3] == 'x')) + ++c; + if (c[3] == ',') + { + c += 4; + break; + } + if (c[3] != '\0') + { + fprintf (stderr, "%s: bad arg-list\n", + ffeintrin_imps_[i].name); + } + break; + } + } +} + +/* Determine whether intrinsic is okay as an actual argument. */ + +bool +ffeintrin_is_actualarg (ffeintrinSpec spec) +{ + ffeIntrinsicState state; + + if (spec >= FFEINTRIN_spec) + return FALSE; + + 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)); +} + +/* Determine if name is intrinsic, return info. + + char *name; // C-string name of possible intrinsic. + ffelexToken t; // NULL if no diagnostic to be given. + bool explicit; // TRUE if INTRINSIC name. + ffeintrinGen gen; // (TRUE only) Generic id of intrinsic. + ffeintrinSpec spec; // (TRUE only) Specific id of intrinsic. + ffeintrinImp imp; // (TRUE only) Implementation id of intrinsic. + if (ffeintrin_is_intrinsic (name, t, explicit, + &gen, &spec, &imp)) + // is an intrinsic, use gen, spec, imp, and + // kind accordingly. */ + +bool +ffeintrin_is_intrinsic (char *name, ffelexToken t, bool explicit, + ffeintrinGen *xgen, ffeintrinSpec *xspec, + ffeintrinImp *ximp) +{ + struct _ffeintrin_name_ *intrinsic; + ffeintrinGen gen; + ffeintrinSpec spec; + ffeintrinImp imp; + ffeIntrinsicState state; + bool disabled = FALSE; + bool unimpl = FALSE; + + intrinsic = bsearch (name, &ffeintrin_names_[0], + ARRAY_SIZE (ffeintrin_names_), + sizeof (struct _ffeintrin_name_), + (void *) ffeintrin_cmp_name_); + + if (intrinsic == NULL) + return FALSE; + + gen = intrinsic->generic; + spec = intrinsic->specific; + imp = ffeintrin_specs_[spec].implementation; + + /* Generic is okay only if at least one of its specifics is okay. */ + + if (gen != FFEINTRIN_genNONE) + { + int i; + ffeintrinSpec tspec; + bool ok = FALSE; + + name = ffeintrin_gens_[gen].name; + + for (i = 0; + (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs)) + && ((tspec + = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE); + ++i) + { + state = ffeintrin_state_family (ffeintrin_specs_[tspec].family); + + if (state == FFE_intrinsicstateDELETED) + continue; + + if (state == FFE_intrinsicstateDISABLED) + { + disabled = TRUE; + continue; + } + + if (ffeintrin_specs_[tspec].implementation == FFEINTRIN_impNONE) + { + unimpl = TRUE; + continue; + } + + if ((state == FFE_intrinsicstateENABLED) + || (explicit + && (state == FFE_intrinsicstateHIDDEN))) + { + ok = TRUE; + break; + } + } + if (!ok) + gen = FFEINTRIN_genNONE; + } + + /* Specific is okay only if not: unimplemented, disabled, deleted, or + hidden and not explicit. */ + + if (spec != FFEINTRIN_specNONE) + { + if (gen != FFEINTRIN_genNONE) + name = ffeintrin_gens_[gen].name; + else + name = ffeintrin_specs_[spec].name; + + if (((state = ffeintrin_state_family (ffeintrin_specs_[spec].family)) + == FFE_intrinsicstateDELETED) + || (!explicit + && (state == FFE_intrinsicstateHIDDEN))) + spec = FFEINTRIN_specNONE; + else if (state == FFE_intrinsicstateDISABLED) + { + disabled = TRUE; + spec = FFEINTRIN_specNONE; + } + else if (imp == FFEINTRIN_impNONE) + { + unimpl = TRUE; + spec = FFEINTRIN_specNONE; + } + } + + /* If neither is okay, not an intrinsic. */ + + if ((gen == FFEINTRIN_genNONE) && (spec == FFEINTRIN_specNONE)) + { + /* Here is where we produce a diagnostic about a reference to a + disabled or unimplemented intrinsic, if the diagnostic is desired. */ + + if ((disabled || unimpl) + && (t != NULL)) + { + ffebad_start (disabled + ? FFEBAD_INTRINSIC_DISABLED + : FFEBAD_INTRINSIC_UNIMPLW); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_string (name); + ffebad_finish (); + } + + return FALSE; + } + + /* Determine whether intrinsic is function or subroutine. If no specific + id, scan list of possible specifics for generic to get consensus. If + not unanimous, or clear from the context, return NONE. */ + + if (spec == FFEINTRIN_specNONE) + { + int i; + ffeintrinSpec tspec; + ffeintrinImp timp; + bool at_least_one_ok = FALSE; + + for (i = 0; + (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs)) + && ((tspec + = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE); + ++i) + { + if (((state = ffeintrin_state_family (ffeintrin_specs_[tspec].family)) + == FFE_intrinsicstateDELETED) + || (state == FFE_intrinsicstateDISABLED)) + continue; + + if ((timp = ffeintrin_specs_[tspec].implementation) + == FFEINTRIN_impNONE) + continue; + + at_least_one_ok = TRUE; + break; + } + + if (!at_least_one_ok) + { + *xgen = FFEINTRIN_genNONE; + *xspec = FFEINTRIN_specNONE; + *ximp = FFEINTRIN_impNONE; + return FALSE; + } + } + + *xgen = gen; + *xspec = spec; + *ximp = imp; + return TRUE; +} + +/* Return TRUE if intrinsic is standard F77 (or, if -ff90, F90). */ + +bool +ffeintrin_is_standard (ffeintrinGen gen, ffeintrinSpec spec) +{ + if (spec == FFEINTRIN_specNONE) + { + if (gen == FFEINTRIN_genNONE) + return FALSE; + + spec = ffeintrin_gens_[gen].specs[0]; + if (spec == FFEINTRIN_specNONE) + return FALSE; + } + + if ((ffeintrin_specs_[spec].family == FFEINTRIN_familyF77) + || (ffe_is_90 () + && ((ffeintrin_specs_[spec].family == FFEINTRIN_familyF90) + || (ffeintrin_specs_[spec].family == FFEINTRIN_familyMIL) + || (ffeintrin_specs_[spec].family == FFEINTRIN_familyASC)))) + return TRUE; + return FALSE; +} + +/* Return kind type of intrinsic implementation. See ffeintrin_basictype, + its sibling. */ + +ffeinfoKindtype +ffeintrin_kindtype (ffeintrinSpec spec) +{ + ffeintrinImp imp; + ffecomGfrt gfrt; + + assert (spec < FFEINTRIN_spec); + imp = ffeintrin_specs_[spec].implementation; + assert (imp < FFEINTRIN_imp); + + if (ffe_is_f2c ()) + gfrt = ffeintrin_imps_[imp].gfrt_f2c; + else + gfrt = ffeintrin_imps_[imp].gfrt_gnu; + + assert (gfrt != FFECOM_gfrt); + + return ffecom_gfrt_kindtype (gfrt); +} + +/* Return name of generic intrinsic. */ + +char * +ffeintrin_name_generic (ffeintrinGen gen) +{ + assert (gen < FFEINTRIN_gen); + return ffeintrin_gens_[gen].name; +} + +/* Return name of intrinsic implementation. */ + +char * +ffeintrin_name_implementation (ffeintrinImp imp) +{ + assert (imp < FFEINTRIN_imp); + return ffeintrin_imps_[imp].name; +} + +/* Return external/internal name of specific intrinsic. */ + +char * +ffeintrin_name_specific (ffeintrinSpec spec) +{ + assert (spec < FFEINTRIN_spec); + return ffeintrin_specs_[spec].name; +} + +/* Return state of family. */ + +ffeIntrinsicState +ffeintrin_state_family (ffeintrinFamily family) +{ + ffeIntrinsicState state; + + switch (family) + { + case FFEINTRIN_familyNONE: + return FFE_intrinsicstateDELETED; + + case FFEINTRIN_familyF77: + return FFE_intrinsicstateENABLED; + + case FFEINTRIN_familyASC: + state = ffe_intrinsic_state_f2c (); + state = ffe_state_max (state, ffe_intrinsic_state_f90 ()); + return state; + + case FFEINTRIN_familyMIL: + state = ffe_intrinsic_state_vxt (); + state = ffe_state_max (state, ffe_intrinsic_state_f90 ()); + state = ffe_state_max (state, ffe_intrinsic_state_mil ()); + return state; + + case FFEINTRIN_familyGNU: + state = ffe_intrinsic_state_gnu (); + return state; + + case FFEINTRIN_familyF90: + state = ffe_intrinsic_state_f90 (); + return state; + + case FFEINTRIN_familyVXT: + state = ffe_intrinsic_state_vxt (); + return state; + + case FFEINTRIN_familyFVZ: + state = ffe_intrinsic_state_f2c (); + state = ffe_state_max (state, ffe_intrinsic_state_vxt ()); + return state; + + case FFEINTRIN_familyF2C: + state = ffe_intrinsic_state_f2c (); + return state; + + case FFEINTRIN_familyF2U: + state = ffe_intrinsic_state_unix (); + return state; + + case FFEINTRIN_familyBADU77: + state = ffe_intrinsic_state_badu77 (); + return state; + + default: + assert ("bad family" == NULL); + return FFE_intrinsicstateDELETED; + } +} diff --git a/gcc/f/intrin.def b/gcc/f/intrin.def new file mode 100644 index 000000000000..66ca3c0a215d --- /dev/null +++ b/gcc/f/intrin.def @@ -0,0 +1,3350 @@ +/* intrin.def -- Public #include File (module.h template V1.0) + The Free Software Foundation has released this file into the + public domain. + + Owning Modules: + intrin.c + + Modifications: +*/ + +/* Intrinsic names listed in alphabetical order, sorted by uppercase name. + This list is keyed to the names of intrinsics as seen in source code. */ + +DEFNAME ("ABORT", "abort", "Abort", genNONE, specABORT) /* UNIX */ +DEFNAME ("ABS", "abs", "Abs", genNONE, specABS) +DEFNAME ("ACCESS", "access", "Access", genNONE, specACCESS) /* UNIX */ +DEFNAME ("ACHAR", "achar", "AChar", genNONE, specACHAR) /* F90, F2C */ +DEFNAME ("ACOS", "acos", "ACos", genNONE, specACOS) +DEFNAME ("ACOSD", "acosd", "ACosD", genNONE, specACOSD) /* VXT */ +DEFNAME ("ADJUSTL", "adjustl", "AdjustL", genNONE, specADJUSTL) /* F90 */ +DEFNAME ("ADJUSTR", "adjustr", "AdjustR", genNONE, specADJUSTR) /* F90 */ +DEFNAME ("AIMAG", "aimag", "AImag", genNONE, specAIMAG) +DEFNAME ("AIMAX0", "aimax0", "AIMax0", genNONE, specAIMAX0) /* VXT */ +DEFNAME ("AIMIN0", "aimin0", "AIMin0", genNONE, specAIMIN0) /* VXT */ +DEFNAME ("AINT", "aint", "AInt", genNONE, specAINT) +DEFNAME ("AJMAX0", "ajmax0", "AJMax0", genNONE, specAJMAX0) /* VXT */ +DEFNAME ("AJMIN0", "ajmin0", "AJMin0", genNONE, specAJMIN0) /* VXT */ +DEFNAME ("ALARM", "alarm", "Alarm", genNONE, specALARM) /* UNIX */ +DEFNAME ("ALL", "all", "All", genNONE, specALL) /* F90 */ +DEFNAME ("ALLOCATED", "allocated", "Allocated", genNONE, specALLOCATED) /* F90 */ +DEFNAME ("ALOG", "alog", "ALog", genNONE, specALOG) +DEFNAME ("ALOG10", "alog10", "ALog10", genNONE, specALOG10) +DEFNAME ("AMAX0", "amax0", "AMax0", genNONE, specAMAX0) +DEFNAME ("AMAX1", "amax1", "AMax1", genNONE, specAMAX1) +DEFNAME ("AMIN0", "amin0", "AMin0", genNONE, specAMIN0) +DEFNAME ("AMIN1", "amin1", "AMin1", genNONE, specAMIN1) +DEFNAME ("AMOD", "amod", "AMod", genNONE, specAMOD) +DEFNAME ("AND", "and", "And", genNONE, specAND) /* F2C */ +DEFNAME ("ANINT", "anint", "ANInt", genNONE, specANINT) +DEFNAME ("ANY", "any", "Any", genNONE, specANY) /* F90 */ +DEFNAME ("ASIN", "asin", "ASin", genNONE, specASIN) +DEFNAME ("ASIND", "asind", "ASinD", genNONE, specASIND) /* VXT */ +DEFNAME ("ASSOCIATED", "associated", "Associated", genNONE, specASSOCIATED) /* F90 */ +DEFNAME ("ATAN", "atan", "ATan", genNONE, specATAN) +DEFNAME ("ATAN2", "atan2", "ATan2", genNONE, specATAN2) +DEFNAME ("ATAN2D", "atan2d", "ATan2D", genNONE, specATAN2D) /* VXT */ +DEFNAME ("ATAND", "atand", "ATanD", genNONE, specATAND) /* VXT */ +DEFNAME ("BESJ0", "besj0", "BesJ0", genNONE, specBESJ0) /* UNIX */ +DEFNAME ("BESJ1", "besj1", "BesJ1", genNONE, specBESJ1) /* UNIX */ +DEFNAME ("BESJN", "besjn", "BesJN", genNONE, specBESJN) /* UNIX */ +DEFNAME ("BESY0", "besy0", "BesY0", genNONE, specBESY0) /* UNIX */ +DEFNAME ("BESY1", "besy1", "BesY1", genNONE, specBESY1) /* UNIX */ +DEFNAME ("BESYN", "besyn", "BesYN", genNONE, specBESYN) /* UNIX */ +DEFNAME ("BITEST", "bitest", "BITest", genNONE, specBITEST) /* VXT */ +DEFNAME ("BIT_SIZE", "bit_size", "Bit_Size", genNONE, specBIT_SIZE) /* F90 */ +DEFNAME ("BJTEST", "bjtest", "BJTest", genNONE, specBJTEST) /* VXT */ +DEFNAME ("BTEST", "btest", "BTest", genNONE, specBTEST) /* F90, VXT */ +DEFNAME ("CABS", "cabs", "CAbs", genNONE, specCABS) +DEFNAME ("CCOS", "ccos", "CCos", genNONE, specCCOS) +DEFNAME ("CDABS", "cdabs", "CDAbs", genNONE, specCDABS) /* VXT */ +DEFNAME ("CDCOS", "cdcos", "CDCos", genNONE, specCDCOS) /* VXT */ +DEFNAME ("CDEXP", "cdexp", "CDExp", genNONE, specCDEXP) /* VXT */ +DEFNAME ("CDLOG", "cdlog", "CDLog", genNONE, specCDLOG) /* VXT */ +DEFNAME ("CDSIN", "cdsin", "CDSin", genNONE, specCDSIN) /* VXT */ +DEFNAME ("CDSQRT", "cdsqrt", "CDSqRt", genNONE, specCDSQRT) /* VXT */ +DEFNAME ("CEILING", "ceiling", "Ceiling", genNONE, specCEILING) /* F90 */ +DEFNAME ("CEXP", "cexp", "CExp", genNONE, specCEXP) +DEFNAME ("CHAR", "char", "Char", genNONE, specCHAR) +DEFNAME ("CHDIR", "chdir", "ChDir", genCHDIR, specNONE) /* UNIX */ +DEFNAME ("CHMOD", "chmod", "ChMod", genCHMOD, specNONE) /* UNIX */ +DEFNAME ("CLOG", "clog", "CLog", genNONE, specCLOG) +DEFNAME ("CMPLX", "cmplx", "Cmplx", genNONE, specCMPLX) +DEFNAME ("COMPLEX", "complex", "Complex", genNONE, specCOMPLEX) +DEFNAME ("CONJG", "conjg", "Conjg", genNONE, specCONJG) +DEFNAME ("COS", "cos", "Cos", genNONE, specCOS) +DEFNAME ("COSD", "cosd", "CosD", genNONE, specCOSD) /* VXT */ +DEFNAME ("COSH", "cosh", "CosH", genNONE, specCOSH) +DEFNAME ("COUNT", "count", "Count", genNONE, specCOUNT) /* F90 */ +DEFNAME ("CPU_TIME", "cpu_time", "Cpu_Time", genNONE, specCPU_TIME) /* F95 */ +DEFNAME ("CSHIFT", "cshift", "CShift", genNONE, specCSHIFT) /* F90 */ +DEFNAME ("CSIN", "csin", "CSin", genNONE, specCSIN) +DEFNAME ("CSQRT", "csqrt", "CSqRt", genNONE, specCSQRT) +DEFNAME ("CTIME", "ctime", "CTime", genCTIME, specNONE) /* UNIX */ +DEFNAME ("DABS", "dabs", "DAbs", genNONE, specDABS) +DEFNAME ("DACOS", "dacos", "DACos", genNONE, specDACOS) +DEFNAME ("DACOSD", "dacosd", "DACosD", genNONE, specDACOSD) /* VXT */ +DEFNAME ("DASIN", "dasin", "DASin", genNONE, specDASIN) +DEFNAME ("DASIND", "dasind", "DASinD", genNONE, specDASIND) /* VXT */ +DEFNAME ("DATAN", "datan", "DATan", genNONE, specDATAN) +DEFNAME ("DATAN2", "datan2", "DATan2", genNONE, specDATAN2) +DEFNAME ("DATAN2D", "datan2d", "DATan2D", genNONE, specDATAN2D) /* VXT */ +DEFNAME ("DATAND", "datand", "DATanD", genNONE, specDATAND) /* VXT */ +DEFNAME ("DATE", "date", "Date", genNONE, specDATE) /* VXT */ +DEFNAME ("DATE_AND_TIME", "date_and_time", "Date_and_Time", genNONE, specDATE_AND_TIME) /* F90 */ +DEFNAME ("DBESJ0", "dbesj0", "DbesJ0", genNONE, specDBESJ0) /* UNIX */ +DEFNAME ("DBESJ1", "dbesj1", "DbesJ1", genNONE, specDBESJ1) /* UNIX */ +DEFNAME ("DBESJN", "dbesjn", "DbesJN", genNONE, specDBESJN) /* UNIX */ +DEFNAME ("DBESY0", "dbesy0", "DbesY0", genNONE, specDBESY0) /* UNIX */ +DEFNAME ("DBESY1", "dbesy1", "DbesY1", genNONE, specDBESY1) /* UNIX */ +DEFNAME ("DBESYN", "dbesyn", "DbesYN", genNONE, specDBESYN) /* UNIX */ +DEFNAME ("DBLE", "dble", "Dble", genNONE, specDBLE) +DEFNAME ("DBLEQ", "dbleq", "DbleQ", genNONE, specDBLEQ) /* VXT */ +DEFNAME ("DCMPLX", "dcmplx", "DCmplx", genNONE, specDCMPLX) /* F2C, VXT */ +DEFNAME ("DCONJG", "dconjg", "DConjg", genNONE, specDCONJG) /* F2C, VXT */ +DEFNAME ("DCOS", "dcos", "DCos", genNONE, specDCOS) +DEFNAME ("DCOSD", "dcosd", "DCosD", genNONE, specDCOSD) /* VXT */ +DEFNAME ("DCOSH", "dcosh", "DCosH", genNONE, specDCOSH) +DEFNAME ("DDIM", "ddim", "DDiM", genNONE, specDDIM) +DEFNAME ("DERF", "derf", "DErF", genNONE, specDERF) /* UNIX */ +DEFNAME ("DERFC", "derfc", "DErFC", genNONE, specDERFC) /* UNIX */ +DEFNAME ("DEXP", "dexp", "DExp", genNONE, specDEXP) +DEFNAME ("DFLOAT", "dfloat", "DFloat", genNONE, specDFLOAT) /* F2C, VXT */ +DEFNAME ("DFLOTI", "dfloti", "DFlotI", genNONE, specDFLOTI) /* VXT */ +DEFNAME ("DFLOTJ", "dflotj", "DFlotJ", genNONE, specDFLOTJ) /* VXT */ +DEFNAME ("DIGITS", "digits", "Digits", genNONE, specDIGITS) /* F90 */ +DEFNAME ("DIM", "dim", "DiM", genNONE, specDIM) +DEFNAME ("DIMAG", "dimag", "DImag", genNONE, specDIMAG) /* F2C, VXT */ +DEFNAME ("DINT", "dint", "DInt", genNONE, specDINT) +DEFNAME ("DLOG", "dlog", "DLog", genNONE, specDLOG) +DEFNAME ("DLOG10", "dlog10", "DLog10", genNONE, specDLOG10) +DEFNAME ("DMAX1", "dmax1", "DMax1", genNONE, specDMAX1) +DEFNAME ("DMIN1", "dmin1", "DMin1", genNONE, specDMIN1) +DEFNAME ("DMOD", "dmod", "DMod", genNONE, specDMOD) +DEFNAME ("DNINT", "dnint", "DNInt", genNONE, specDNINT) +DEFNAME ("DOT_PRODUCT", "dot_product", "Dot_Product", genNONE, specDOT_PRODUCT) /* F90 */ +DEFNAME ("DPROD", "dprod", "DProd", genNONE, specDPROD) +DEFNAME ("DREAL", "dreal", "DReal", genNONE, specDREAL) /* VXT */ +DEFNAME ("DSIGN", "dsign", "DSign", genNONE, specDSIGN) +DEFNAME ("DSIN", "dsin", "DSin", genNONE, specDSIN) +DEFNAME ("DSIND", "dsind", "DSinD", genNONE, specDSIND) /* VXT */ +DEFNAME ("DSINH", "dsinh", "DSinH", genNONE, specDSINH) +DEFNAME ("DSQRT", "dsqrt", "DSqRt", genNONE, specDSQRT) +DEFNAME ("DTAN", "dtan", "DTan", genNONE, specDTAN) +DEFNAME ("DTAND", "dtand", "DTanD", genNONE, specDTAND) /* VXT */ +DEFNAME ("DTANH", "dtanh", "DTanH", genNONE, specDTANH) +DEFNAME ("DTIME", "dtime", "Dtime", genDTIME, specNONE) /* UNIX */ +DEFNAME ("EOSHIFT", "eoshift", "EOShift", genNONE, specEOSHIFT) /* F90 */ +DEFNAME ("EPSILON", "epsilon", "Epsilon", genNONE, specEPSILON) /* F90 */ +DEFNAME ("ERF", "erf", "ErF", genNONE, specERF) /* UNIX */ +DEFNAME ("ERFC", "erfc", "ErFC", genNONE, specERFC) /* UNIX */ +DEFNAME ("ETIME", "etime", "ETime", genETIME, specNONE) /* UNIX */ +DEFNAME ("EXIT", "exit", "Exit", genNONE, specEXIT) /* UNIX */ +DEFNAME ("EXP", "exp", "Exp", genNONE, specEXP) +DEFNAME ("EXPONENT", "exponent", "Exponent", genNONE, specEXPONENT) /* F90 */ +DEFNAME ("FDATE", "fdate", "Fdate", genFDATE, specNONE) /* UNIX */ +DEFNAME ("FGET", "fget", "FGet", genFGET, specNONE) /* UNIX */ +DEFNAME ("FGETC", "fgetc", "FGetC", genFGETC, specNONE) /* UNIX */ +DEFNAME ("FLOAT", "float", "Float", genNONE, specFLOAT) +DEFNAME ("FLOATI", "floati", "FloatI", genNONE, specFLOATI) /* VXT */ +DEFNAME ("FLOATJ", "floatj", "FloatJ", genNONE, specFLOATJ) /* VXT */ +DEFNAME ("FLOOR", "floor", "Floor", genNONE, specFLOOR) /* F90 */ +DEFNAME ("FLUSH", "flush", "Flush", genNONE, specFLUSH) /* UNIX */ +DEFNAME ("FNUM", "fnum", "FNum", genNONE, specFNUM) /* UNIX */ +DEFNAME ("FPABSP", "fpabsp", "FPAbsP", genFPABSP, specNONE) /* F2C */ +DEFNAME ("FPEXPN", "fpexpn", "FPExpn", genFPEXPN, specNONE) /* F2C */ +DEFNAME ("FPFRAC", "fpfrac", "FPFrac", genFPFRAC, specNONE) /* F2C */ +DEFNAME ("FPMAKE", "fpmake", "FPMake", genFPMAKE, specNONE) /* F2C */ +DEFNAME ("FPRRSP", "fprrsp", "FPRRSp", genFPRRSP, specNONE) /* F2C */ +DEFNAME ("FPSCAL", "fpscal", "FPScal", genFPSCAL, specNONE) /* F2C */ +DEFNAME ("FPUT", "fput", "FPut", genFPUT, specNONE) /* UNIX */ +DEFNAME ("FPUTC", "fputc", "FPutC", genFPUTC, specNONE) /* UNIX */ +DEFNAME ("FRACTION", "fraction", "Fraction", genNONE, specFRACTION) /* F90 */ +DEFNAME ("FSEEK", "fseek", "FSeek", genNONE, specFSEEK) /* UNIX */ +DEFNAME ("FSTAT", "fstat", "FStat", genFSTAT, specNONE) /* UNIX */ +DEFNAME ("FTELL", "ftell", "FTell", genFTELL, specNONE) /* UNIX */ +DEFNAME ("GERROR", "gerror", "GError", genNONE, specGERROR) /* UNIX */ +DEFNAME ("GETARG", "getarg", "GetArg", genNONE, specGETARG) /* UNIX */ +DEFNAME ("GETCWD", "getcwd", "GetCWD", genGETCWD, specNONE) /* UNIX */ +DEFNAME ("GETENV", "getenv", "GetEnv", genNONE, specGETENV) /* UNIX */ +DEFNAME ("GETGID", "getgid", "GetGId", genNONE, specGETGID) /* UNIX */ +DEFNAME ("GETLOG", "getlog", "GetLog", genNONE, specGETLOG) /* UNIX */ +DEFNAME ("GETPID", "getpid", "GetPId", genNONE, specGETPID) /* UNIX */ +DEFNAME ("GETUID", "getuid", "GetUId", genNONE, specGETUID) /* UNIX */ +DEFNAME ("GMTIME", "gmtime", "GMTime", genNONE, specGMTIME) /* UNIX */ +DEFNAME ("HOSTNM", "hostnm", "HostNm", genHOSTNM, specNONE) /* UNIX */ +DEFNAME ("HUGE", "huge", "Huge", genNONE, specHUGE) /* F90 */ +DEFNAME ("IABS", "iabs", "IAbs", genNONE, specIABS) +DEFNAME ("IACHAR", "iachar", "IAChar", genNONE, specIACHAR) /* F90, F2C */ +DEFNAME ("IAND", "iand", "IAnd", genNONE, specIAND) /* F90, VXT */ +DEFNAME ("IARGC", "iargc", "IArgC", genNONE, specIARGC) /* UNIX */ +DEFNAME ("IBCLR", "ibclr", "IBClr", genNONE, specIBCLR) /* F90, VXT */ +DEFNAME ("IBITS", "ibits", "IBits", genNONE, specIBITS) /* F90, VXT */ +DEFNAME ("IBSET", "ibset", "IBSet", genNONE, specIBSET) /* F90, VXT */ +DEFNAME ("ICHAR", "ichar", "IChar", genNONE, specICHAR) +DEFNAME ("IDATE", "idate", "IDate", genIDATE, specNONE) /* UNIX, VXT */ +DEFNAME ("IDIM", "idim", "IDiM", genNONE, specIDIM) +DEFNAME ("IDINT", "idint", "IDInt", genNONE, specIDINT) +DEFNAME ("IDNINT", "idnint", "IDNInt", genNONE, specIDNINT) +DEFNAME ("IEOR", "ieor", "IEOr", genNONE, specIEOR) /* F90, VXT */ +DEFNAME ("IERRNO", "ierrno", "IErrNo", genNONE, specIERRNO) /* UNIX */ +DEFNAME ("IFIX", "ifix", "IFix", genNONE, specIFIX) +DEFNAME ("IIABS", "iiabs", "IIAbs", genNONE, specIIABS) /* VXT */ +DEFNAME ("IIAND", "iiand", "IIAnd", genNONE, specIIAND) /* VXT */ +DEFNAME ("IIBCLR", "iibclr", "IIBClr", genNONE, specIIBCLR) /* VXT */ +DEFNAME ("IIBITS", "iibits", "IIBits", genNONE, specIIBITS) /* VXT */ +DEFNAME ("IIBSET", "iibset", "IIBSet", genNONE, specIIBSET) /* VXT */ +DEFNAME ("IIDIM", "iidim", "IIDiM", genNONE, specIIDIM) /* VXT */ +DEFNAME ("IIDINT", "iidint", "IIDInt", genNONE, specIIDINT) /* VXT */ +DEFNAME ("IIDNNT", "iidnnt", "IIDNnt", genNONE, specIIDNNT) /* VXT */ +DEFNAME ("IIEOR", "iieor", "IIEOr", genNONE, specIIEOR) /* VXT */ +DEFNAME ("IIFIX", "iifix", "IIFix", genNONE, specIIFIX) /* VXT */ +DEFNAME ("IINT", "iint", "IInt", genNONE, specIINT) /* VXT */ +DEFNAME ("IIOR", "iior", "IIOr", genNONE, specIIOR) /* VXT */ +DEFNAME ("IIQINT", "iiqint", "IIQint", genNONE, specIIQINT) /* VXT */ +DEFNAME ("IIQNNT", "iiqnnt", "IIQNnt", genNONE, specIIQNNT) /* VXT */ +DEFNAME ("IISHFT", "iishft", "IIShft", genNONE, specNONE) /* VXT */ +DEFNAME ("IISHFTC", "iishftc", "IIShftC", genNONE, specIISHFTC) /* VXT */ +DEFNAME ("IISIGN", "iisign", "IISign", genNONE, specIISIGN) /* VXT */ +DEFNAME ("IMAG", "imag", "Imag", genNONE, specIMAG) /* F2C */ +DEFNAME ("IMAGPART", "imagpart", "ImagPart", genNONE, specIMAGPART) /* GNU */ +DEFNAME ("IMAX0", "imax0", "IMax0", genNONE, specIMAX0) /* VXT */ +DEFNAME ("IMAX1", "imax1", "IMax1", genNONE, specIMAX1) /* VXT */ +DEFNAME ("IMIN0", "imin0", "IMin0", genNONE, specIMIN0) /* VXT */ +DEFNAME ("IMIN1", "imin1", "IMin1", genNONE, specIMIN1) /* VXT */ +DEFNAME ("IMOD", "imod", "IMod", genNONE, specIMOD) /* VXT */ +DEFNAME ("INDEX", "index", "Index", genNONE, specINDEX) +DEFNAME ("ININT", "inint", "INInt", genNONE, specININT) /* VXT */ +DEFNAME ("INOT", "inot", "INot", genNONE, specINOT) /* VXT */ +DEFNAME ("INT", "int", "Int", genNONE, specINT) +DEFNAME ("INT2", "int2", "Int2", genNONE, specINT2) /* MS */ +DEFNAME ("INT8", "int8", "Int8", genNONE, specINT8) /* GNU */ +DEFNAME ("IOR", "ior", "IOr", genNONE, specIOR) /* F90, VXT */ +DEFNAME ("IRAND", "irand", "IRand", genNONE, specIRAND) /* UNIX */ +DEFNAME ("ISATTY", "isatty", "IsaTty", genNONE, specISATTY) /* UNIX */ +DEFNAME ("ISHFT", "ishft", "IShft", genNONE, specISHFT) /* F90 */ +DEFNAME ("ISHFTC", "ishftc", "IShftC", genNONE, specISHFTC) /* F90, VXT */ +DEFNAME ("ISIGN", "isign", "ISign", genNONE, specISIGN) +DEFNAME ("ITIME", "itime", "ITime", genNONE, specITIME) /* UNIX */ +DEFNAME ("IZEXT", "izext", "IZExt", genNONE, specIZEXT) /* VXT */ +DEFNAME ("JIABS", "jiabs", "JIAbs", genNONE, specJIABS) /* VXT */ +DEFNAME ("JIAND", "jiand", "JIAnd", genNONE, specJIAND) /* VXT */ +DEFNAME ("JIBCLR", "jibclr", "JIBClr", genNONE, specJIBCLR) /* VXT */ +DEFNAME ("JIBITS", "jibits", "JIBits", genNONE, specJIBITS) /* VXT */ +DEFNAME ("JIBSET", "jibset", "JIBSet", genNONE, specJIBSET) /* VXT */ +DEFNAME ("JIDIM", "jidim", "JIDiM", genNONE, specJIDIM) /* VXT */ +DEFNAME ("JIDINT", "jidint", "JIDInt", genNONE, specJIDINT) /* VXT */ +DEFNAME ("JIDNNT", "jidnnt", "JIDNnt", genNONE, specJIDNNT) /* VXT */ +DEFNAME ("JIEOR", "jieor", "JIEOr", genNONE, specJIEOR) /* VXT */ +DEFNAME ("JIFIX", "jifix", "JIFix", genNONE, specJIFIX) /* VXT */ +DEFNAME ("JINT", "jint", "JInt", genNONE, specJINT) /* VXT */ +DEFNAME ("JIOR", "jior", "JIOr", genNONE, specJIOR) /* VXT */ +DEFNAME ("JIQINT", "jiqint", "JIQint", genNONE, specJIQINT) /* VXT */ +DEFNAME ("JIQNNT", "jiqnnt", "JIQNnt", genNONE, specJIQNNT) /* VXT */ +DEFNAME ("JISHFT", "jishft", "JIShft", genNONE, specJISHFT) /* VXT */ +DEFNAME ("JISHFTC", "jishftc", "JIShftC", genNONE, specJISHFTC) /* VXT */ +DEFNAME ("JISIGN", "jisign", "JISign", genNONE, specJISIGN) /* VXT */ +DEFNAME ("JMAX0", "jmax0", "JMax0", genNONE, specJMAX0) /* VXT */ +DEFNAME ("JMAX1", "jmax1", "JMax1", genNONE, specJMAX1) /* VXT */ +DEFNAME ("JMIN0", "jmin0", "JMin0", genNONE, specJMIN0) /* VXT */ +DEFNAME ("JMIN1", "jmin1", "JMin1", genNONE, specJMIN1) /* VXT */ +DEFNAME ("JMOD", "jmod", "JMod", genNONE, specJMOD) /* VXT */ +DEFNAME ("JNINT", "jnint", "JNInt", genNONE, specJNINT) /* VXT */ +DEFNAME ("JNOT", "jnot", "JNot", genNONE, specJNOT) /* VXT */ +DEFNAME ("JZEXT", "jzext", "JZExt", genNONE, specJZEXT) /* VXT */ +DEFNAME ("KILL", "kill", "Kill", genKILL, specNONE) /* UNIX */ +DEFNAME ("KIND", "kind", "Kind", genNONE, specKIND) /* F90 */ +DEFNAME ("LBOUND", "lbound", "LBound", genNONE, specLBOUND) /* F90 */ +DEFNAME ("LEN", "len", "Len", genNONE, specLEN) +DEFNAME ("LEN_TRIM", "len_trim", "Len_Trim", genNONE, specLEN_TRIM) /* F90 */ +DEFNAME ("LGE", "lge", "LGe", genNONE, specLGE) +DEFNAME ("LGT", "lgt", "LGt", genNONE, specLGT) +DEFNAME ("LINK", "link", "Link", genLINK, specNONE) /* UNIX */ +DEFNAME ("LLE", "lle", "LLe", genNONE, specLLE) +DEFNAME ("LLT", "llt", "LLt", genNONE, specLLT) +DEFNAME ("LNBLNK", "lnblnk", "LnBlnk", genNONE, specLNBLNK) /* UNIX */ +DEFNAME ("LOC", "loc", "Loc", genNONE, specLOC) /* VXT */ +DEFNAME ("LOG", "log", "Log", genNONE, specLOG) +DEFNAME ("LOG10", "log10", "Log10", genNONE, specLOG10) +DEFNAME ("LOGICAL", "logical", "Logical", genNONE, specLOGICAL) /* F90 */ +DEFNAME ("LONG", "long", "Long", genNONE, specLONG) /* UNIX */ +DEFNAME ("LSHIFT", "lshift", "LShift", genNONE, specLSHIFT) /* F2C */ +DEFNAME ("LSTAT", "lstat", "LStat", genLSTAT, specNONE) /* UNIX */ +DEFNAME ("LTIME", "ltime", "LTime", genNONE, specLTIME) /* UNIX */ +DEFNAME ("MATMUL", "matmul", "MatMul", genNONE, specMATMUL) /* F90 */ +DEFNAME ("MAX", "max", "Max", genNONE, specMAX) +DEFNAME ("MAX0", "max0", "Max0", genNONE, specMAX0) +DEFNAME ("MAX1", "max1", "Max1", genNONE, specMAX1) +DEFNAME ("MAXEXPONENT", "maxexponent", "MaxExponent", genNONE, specMAXEXPONENT) /* F90 */ +DEFNAME ("MAXLOC", "maxloc", "MaxLoc", genNONE, specMAXLOC) /* F90 */ +DEFNAME ("MAXVAL", "maxval", "MaxVal", genNONE, specMAXVAL) /* F90 */ +DEFNAME ("MCLOCK", "mclock", "MClock", genNONE, specMCLOCK) /* UNIX */ +DEFNAME ("MCLOCK8", "mclock8", "MClock8", genNONE, specMCLOCK8) /* UNIX */ +DEFNAME ("MERGE", "merge", "Merge", genNONE, specMERGE) /* F90 */ +DEFNAME ("MIN", "min", "Min", genNONE, specMIN) +DEFNAME ("MIN0", "min0", "Min0", genNONE, specMIN0) +DEFNAME ("MIN1", "min1", "Min1", genNONE, specMIN1) +DEFNAME ("MINEXPONENT", "minexponent", "MinExponent", genNONE, specMINEXPONENT) /* F90 */ +DEFNAME ("MINLOC", "minloc", "MinLoc", genNONE, specMINLOC) /* F90 */ +DEFNAME ("MINVAL", "minval", "MinVal", genNONE, specMINVAL) /* F90 */ +DEFNAME ("MOD", "mod", "Mod", genNONE, specMOD) +DEFNAME ("MODULO", "modulo", "Modulo", genNONE, specMODULO) /* F90 */ +DEFNAME ("MVBITS", "mvbits", "MvBits", genNONE, specMVBITS) /* F90 */ +DEFNAME ("NEAREST", "nearest", "Nearest", genNONE, specNEAREST) /* F90 */ +DEFNAME ("NINT", "nint", "NInt", genNONE, specNINT) +DEFNAME ("NOT", "not", "Not", genNONE, specNOT) /* F2C, F90, VXT */ +DEFNAME ("OR", "or", "Or", genNONE, specOR) /* F2C */ +DEFNAME ("PACK", "pack", "Pack", genNONE, specPACK) /* F90 */ +DEFNAME ("PERROR", "perror", "PError", genNONE, specPERROR) /* UNIX */ +DEFNAME ("PRECISION", "precision", "Precision", genNONE, specPRECISION) /* F90 */ +DEFNAME ("PRESENT", "present", "Present", genNONE, specPRESENT) /* F90 */ +DEFNAME ("PRODUCT", "product", "Product", genNONE, specPRODUCT) /* F90 */ +DEFNAME ("QABS", "qabs", "QAbs", genNONE, specQABS) /* VXT */ +DEFNAME ("QACOS", "qacos", "QACos", genNONE, specQACOS) /* VXT */ +DEFNAME ("QACOSD", "qacosd", "QACosD", genNONE, specQACOSD) /* VXT */ +DEFNAME ("QASIN", "qasin", "QASin", genNONE, specQASIN) /* VXT */ +DEFNAME ("QASIND", "qasind", "QASinD", genNONE, specQASIND) /* VXT */ +DEFNAME ("QATAN", "qatan", "QATan", genNONE, specQATAN) /* VXT */ +DEFNAME ("QATAN2", "qatan2", "QATan2", genNONE, specQATAN2) /* VXT */ +DEFNAME ("QATAN2D", "qatan2d", "QATan2D", genNONE, specQATAN2D) /* VXT */ +DEFNAME ("QATAND", "qatand", "QATanD", genNONE, specQATAND) /* VXT */ +DEFNAME ("QCOS", "qcos", "QCos", genNONE, specQCOS) /* VXT */ +DEFNAME ("QCOSD", "qcosd", "QCosD", genNONE, specQCOSD) /* VXT */ +DEFNAME ("QCOSH", "qcosh", "QCosH", genNONE, specQCOSH) /* VXT */ +DEFNAME ("QDIM", "qdim", "QDiM", genNONE, specQDIM) /* VXT */ +DEFNAME ("QEXP", "qexp", "QExp", genNONE, specQEXP) /* VXT */ +DEFNAME ("QEXT", "qext", "QExt", genNONE, specQEXT) /* VXT */ +DEFNAME ("QEXTD", "qextd", "QExtD", genNONE, specQEXTD) /* VXT */ +DEFNAME ("QFLOAT", "qfloat", "QFloat", genNONE, specQFLOAT) /* VXT */ +DEFNAME ("QINT", "qint", "QInt", genNONE, specQINT) /* VXT */ +DEFNAME ("QLOG", "qlog", "QLog", genNONE, specQLOG) /* VXT */ +DEFNAME ("QLOG10", "qlog10", "QLog10", genNONE, specQLOG10) /* VXT */ +DEFNAME ("QMAX1", "qmax1", "QMax1", genNONE, specQMAX1) /* VXT */ +DEFNAME ("QMIN1", "qmin1", "QMin1", genNONE, specQMIN1) /* VXT */ +DEFNAME ("QMOD", "qmod", "QMod", genNONE, specQMOD) /* VXT */ +DEFNAME ("QNINT", "qnint", "QNInt", genNONE, specQNINT) /* VXT */ +DEFNAME ("QSIN", "qsin", "QSin", genNONE, specQSIN) /* VXT */ +DEFNAME ("QSIND", "qsind", "QSinD", genNONE, specQSIND) /* VXT */ +DEFNAME ("QSINH", "qsinh", "QSinH", genNONE, specQSINH) /* VXT */ +DEFNAME ("QSQRT", "qsqrt", "QSqRt", genNONE, specQSQRT) /* VXT */ +DEFNAME ("QTAN", "qtan", "QTan", genNONE, specQTAN) /* VXT */ +DEFNAME ("QTAND", "qtand", "QTanD", genNONE, specQTAND) /* VXT */ +DEFNAME ("QTANH", "qtanh", "QTanH", genNONE, specQTANH) /* VXT */ +DEFNAME ("RADIX", "radix", "Radix", genNONE, specRADIX) /* F90 */ +DEFNAME ("RAND", "rand", "Rand", genNONE, specRAND) /* UNIX */ +DEFNAME ("RANDOM_NUMBER", "random_number", "Random_Number", genNONE, specRANDOM_NUMBER) /* F90 */ +DEFNAME ("RANDOM_SEED", "random_seed", "Random_Seed", genNONE, specRANDOM_SEED) /* F90 */ +DEFNAME ("RANGE", "range", "Range", genNONE, specRANGE) /* F90 */ +DEFNAME ("REAL", "real", "Real", genNONE, specREAL) +DEFNAME ("REALPART", "realpart", "RealPart", genNONE, specREALPART) /* GNU */ +DEFNAME ("RENAME", "rename", "Rename", genRENAME, specNONE) /* UNIX */ +DEFNAME ("REPEAT", "repeat", "Repeat", genNONE, specREPEAT) /* F90 */ +DEFNAME ("RESHAPE", "reshape", "Reshape", genNONE, specRESHAPE) /* F90 */ +DEFNAME ("RRSPACING", "rrspacing", "RRSpacing", genNONE, specRRSPACING) /* F90 */ +DEFNAME ("RSHIFT", "rshift", "RShift", genNONE, specRSHIFT) /* F2C */ +DEFNAME ("SCALE", "scale", "Scale", genNONE, specSCALE) /* F90 */ +DEFNAME ("SCAN", "scan", "Scan", genNONE, specSCAN) /* F90 */ +DEFNAME ("SECNDS", "secnds", "Secnds", genNONE, specSECNDS) /* VXT */ +DEFNAME ("SECOND", "second", "Second", genSECOND, specNONE) /* UNIX */ +DEFNAME ("SELECTED_INT_KIND", "selected_int_kind", "Selected_Int_Kind", genNONE, specSEL_INT_KIND) /* F90 */ +DEFNAME ("SELECTED_REAL_KIND", "selected_real_kind", "Selected_Real_Kind", genNONE, specSEL_REAL_KIND) /* F90 */ +DEFNAME ("SET_EXPONENT", "set_exponent", "Set_Exponent", genNONE, specSET_EXPONENT) /* F90 */ +DEFNAME ("SHAPE", "shape", "Shape", genNONE, specSHAPE) /* F90 */ +DEFNAME ("SHORT", "short", "Short", genNONE, specSHORT) /* UNIX */ +DEFNAME ("SIGN", "sign", "Sign", genNONE, specSIGN) +DEFNAME ("SIGNAL", "signal", "Signal", genSIGNAL, specNONE) /* UNIX */ +DEFNAME ("SIN", "sin", "Sin", genNONE, specSIN) +DEFNAME ("SIND", "sind", "SinD", genNONE, specSIND) /* VXT */ +DEFNAME ("SINH", "sinh", "SinH", genNONE, specSINH) +DEFNAME ("SLEEP", "sleep", "Sleep", genNONE, specSLEEP) /* UNIX */ +DEFNAME ("SNGL", "sngl", "Sngl", genNONE, specSNGL) +DEFNAME ("SNGLQ", "snglq", "SnglQ", genNONE, specSNGLQ) /* VXT */ +DEFNAME ("SPACING", "spacing", "Spacing", genNONE, specSPACING) /* F90 */ +DEFNAME ("SPREAD", "spread", "Spread", genNONE, specSPREAD) /* F90 */ +DEFNAME ("SQRT", "sqrt", "SqRt", genNONE, specSQRT) +DEFNAME ("SRAND", "srand", "SRand", genNONE, specSRAND) /* UNIX */ +DEFNAME ("STAT", "stat", "Stat", genSTAT, specNONE) /* UNIX */ +DEFNAME ("SUM", "sum", "Sum", genNONE, specSUM) /* F90 */ +DEFNAME ("SYMLNK", "symlnk", "SymLnk", genSYMLNK, specNONE) /* UNIX */ +DEFNAME ("SYSTEM", "system", "System", genSYSTEM, specNONE) /* UNIX */ +DEFNAME ("SYSTEM_CLOCK", "system_clock", "System_Clock", genNONE, specSYSTEM_CLOCK) /* F90 */ +DEFNAME ("TAN", "tan", "Tan", genNONE, specTAN) +DEFNAME ("TAND", "tand", "TanD", genNONE, specTAND) /* VXT */ +DEFNAME ("TANH", "tanh", "TanH", genNONE, specTANH) +DEFNAME ("TIME", "time", "Time", genTIME, specNONE) /* UNIX, VXT */ +DEFNAME ("TIME8", "time8", "Time8", genNONE, specTIME8) /* UNIX */ +DEFNAME ("TINY", "tiny", "Tiny", genNONE, specTINY) /* F90 */ +DEFNAME ("TRANSFER", "transfer", "Transfer", genNONE, specTRANSFER) /* F90 */ +DEFNAME ("TRANSPOSE", "transpose", "Transpose", genNONE, specTRANSPOSE) /* F90 */ +DEFNAME ("TRIM", "trim", "Trim", genNONE, specTRIM) /* F90 */ +DEFNAME ("TTYNAM", "ttynam", "TtyNam", genTTYNAM, specNONE) /* UNIX */ +DEFNAME ("UBOUND", "ubound", "UBound", genNONE, specUBOUND) /* F90 */ +DEFNAME ("UMASK", "umask", "UMask", genUMASK, specNONE) /* UNIX */ +DEFNAME ("UNLINK", "unlink", "Unlink", genUNLINK, specNONE) /* UNIX */ +DEFNAME ("UNPACK", "unpack", "Unpack", genNONE, specUNPACK) /* F90 */ +DEFNAME ("VERIFY", "verify", "Verify", genNONE, specVERIFY) /* F90 */ +DEFNAME ("XOR", "xor", "XOr", genNONE, specXOR) /* F2C */ +DEFNAME ("ZABS", "zabs", "ZAbs", genNONE, specZABS) /* F2C */ +DEFNAME ("ZCOS", "zcos", "ZCos", genNONE, specZCOS) /* F2C */ +DEFNAME ("ZEXP", "zexp", "ZExp", genNONE, specZEXP) /* F2C */ +DEFNAME ("ZEXT", "zext", "ZExt", genNONE, specZEXT) /* VXT */ +DEFNAME ("ZLOG", "zlog", "ZLog", genNONE, specZLOG) /* F2C */ +DEFNAME ("ZSIN", "zsin", "ZSin", genNONE, specZSIN) /* F2C */ +DEFNAME ("ZSQRT", "zsqrt", "ZSqRt", genNONE, specZSQRT) /* F2C */ + +/* Internally generic intrinsics. + + Should properly be called "mapped" intrinsics. These are intrinsics + that map to one or more generally different implementations -- e.g. + that have differing interpretations depending on the Fortran dialect + being used. Also, this includes the placeholder intrinsics that + have no specific versions, but we want to reserve the names for now. */ + +DEFGEN (CTIME, "CTIME", /* UNIX */ + FFEINTRIN_specCTIME_subr, + FFEINTRIN_specCTIME_func + ) +DEFGEN (CHDIR, "CHDIR", /* UNIX */ + FFEINTRIN_specCHDIR_subr, + FFEINTRIN_specCHDIR_func + ) +DEFGEN (CHMOD, "CHMOD", /* UNIX */ + FFEINTRIN_specCHMOD_subr, + FFEINTRIN_specCHMOD_func + ) +DEFGEN (DTIME, "DTIME", /* UNIX */ + FFEINTRIN_specDTIME_subr, + FFEINTRIN_specDTIME_func + ) +DEFGEN (ETIME, "ETIME", /* UNIX */ + FFEINTRIN_specETIME_subr, + FFEINTRIN_specETIME_func + ) +DEFGEN (FDATE, "FDATE", /* UNIX */ + FFEINTRIN_specFDATE_subr, + FFEINTRIN_specFDATE_func + ) +DEFGEN (FGET, "FGET", /* UNIX */ + FFEINTRIN_specFGET_subr, + FFEINTRIN_specFGET_func + ) +DEFGEN (FGETC, "FGETC", /* UNIX */ + FFEINTRIN_specFGETC_subr, + FFEINTRIN_specFGETC_func + ) +DEFGEN (FPABSP, "FPABSP", /* F2C */ + FFEINTRIN_specNONE, + FFEINTRIN_specNONE + ) +DEFGEN (FPEXPN, "FPEXPN", /* F2C */ + FFEINTRIN_specNONE, + FFEINTRIN_specNONE + ) +DEFGEN (FPFRAC, "FPFRAC", /* F2C */ + FFEINTRIN_specNONE, + FFEINTRIN_specNONE + ) +DEFGEN (FPMAKE, "FPMAKE", /* F2C */ + FFEINTRIN_specNONE, + FFEINTRIN_specNONE + ) +DEFGEN (FPRRSP, "FPRRSP", /* F2C */ + FFEINTRIN_specNONE, + FFEINTRIN_specNONE + ) +DEFGEN (FPSCAL, "FPSCAL", /* F2C */ + FFEINTRIN_specNONE, + FFEINTRIN_specNONE + ) +DEFGEN (FPUT, "FPUT", /* UNIX */ + FFEINTRIN_specFPUT_subr, + FFEINTRIN_specFPUT_func + ) +DEFGEN (FPUTC, "FPUTC", /* UNIX */ + FFEINTRIN_specFPUTC_subr, + FFEINTRIN_specFPUTC_func + ) +DEFGEN (FSTAT, "FSTAT", /* UNIX */ + FFEINTRIN_specFSTAT_subr, + FFEINTRIN_specFSTAT_func + ) +DEFGEN (FTELL, "FTELL", /* UNIX */ + FFEINTRIN_specFTELL_subr, + FFEINTRIN_specFTELL_func + ) +DEFGEN (GETCWD, "GETCWD", /* UNIX */ + FFEINTRIN_specGETCWD_subr, + FFEINTRIN_specGETCWD_func + ) +DEFGEN (HOSTNM, "HOSTNM", /* UNIX */ + FFEINTRIN_specHOSTNM_subr, + FFEINTRIN_specHOSTNM_func + ) +DEFGEN (IDATE, "IDATE", /* UNIX/VXT */ + FFEINTRIN_specIDATE_unix, + FFEINTRIN_specIDATE_vxt + ) +DEFGEN (KILL, "KILL", /* UNIX */ + FFEINTRIN_specKILL_subr, + FFEINTRIN_specKILL_func + ) +DEFGEN (LINK, "LINK", /* UNIX */ + FFEINTRIN_specLINK_subr, + FFEINTRIN_specLINK_func + ) +DEFGEN (LSTAT, "LSTAT", /* UNIX */ + FFEINTRIN_specLSTAT_subr, + FFEINTRIN_specLSTAT_func + ) +DEFGEN (RENAME, "RENAME", /* UNIX */ + FFEINTRIN_specRENAME_subr, + FFEINTRIN_specRENAME_func + ) +DEFGEN (SECOND, "SECOND", /* UNIX/CRAY */ + FFEINTRIN_specSECOND_func, + FFEINTRIN_specSECOND_subr + ) +DEFGEN (SIGNAL, "SIGNAL", /* UNIX */ + FFEINTRIN_specSIGNAL_subr, + FFEINTRIN_specSIGNAL_func + ) +DEFGEN (STAT, "STAT", /* UNIX */ + FFEINTRIN_specSTAT_subr, + FFEINTRIN_specSTAT_func + ) +DEFGEN (SYMLNK, "SYMLNK", /* UNIX */ + FFEINTRIN_specSYMLNK_subr, + FFEINTRIN_specSYMLNK_func + ) +DEFGEN (SYSTEM, "SYSTEM", /* UNIX */ + FFEINTRIN_specSYSTEM_subr, + FFEINTRIN_specSYSTEM_func + ) +DEFGEN (TIME, "TIME", /* UNIX/VXT */ + FFEINTRIN_specTIME_unix, + FFEINTRIN_specTIME_vxt + ) +DEFGEN (TTYNAM, "TTYNAM", /* UNIX/VXT */ + FFEINTRIN_specTTYNAM_subr, + FFEINTRIN_specTTYNAM_func + ) +DEFGEN (UMASK, "UMASK", /* UNIX */ + FFEINTRIN_specUMASK_subr, + FFEINTRIN_specUMASK_func + ) +DEFGEN (UNLINK, "UNLINK", /* UNIX */ + FFEINTRIN_specUNLINK_subr, + FFEINTRIN_specUNLINK_func + ) +DEFGEN (NONE, "none", + FFEINTRIN_specNONE, + FFEINTRIN_specNONE + ) + +/* Specific intrinsic information. + + Currently this list starts with the list of F77-standard intrinsics + in alphabetical order, then continues with the list of all other + intrinsics. + + The second boolean argument specifies whether the intrinsic is + allowed by the standard to be passed as an actual argument. */ + +DEFSPEC (ABS, + "ABS", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impABS + ) +DEFSPEC (ACOS, + "ACOS", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impACOS + ) +DEFSPEC (AIMAG, + "AIMAG", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impAIMAG + ) +DEFSPEC (AINT, + "AINT", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impAINT + ) +DEFSPEC (ALOG, + "ALOG", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impALOG + ) +DEFSPEC (ALOG10, + "ALOG10", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impALOG10 + ) +DEFSPEC (AMAX0, + "AMAX0", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impAMAX0 + ) +DEFSPEC (AMAX1, + "AMAX1", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impAMAX1 + ) +DEFSPEC (AMIN0, + "AMIN0", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impAMIN0 + ) +DEFSPEC (AMIN1, + "AMIN1", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impAMIN1 + ) +DEFSPEC (AMOD, + "AMOD", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impAMOD + ) +DEFSPEC (ANINT, + "ANINT", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impANINT + ) +DEFSPEC (ASIN, + "ASIN", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impASIN + ) +DEFSPEC (ATAN, + "ATAN", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impATAN + ) +DEFSPEC (ATAN2, + "ATAN2", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impATAN2 + ) +DEFSPEC (CABS, + "CABS", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impCABS + ) +DEFSPEC (CCOS, + "CCOS", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impCCOS + ) +DEFSPEC (CEXP, + "CEXP", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impCEXP + ) +DEFSPEC (CHAR, + "CHAR", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impCHAR + ) +DEFSPEC (CLOG, + "CLOG", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impCLOG + ) +DEFSPEC (CMPLX, + "CMPLX", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impCMPLX + ) +DEFSPEC (CONJG, + "CONJG", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impCONJG + ) +DEFSPEC (COS, + "COS", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impCOS + ) +DEFSPEC (COSH, + "COSH", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impCOSH + ) +DEFSPEC (CSIN, + "CSIN", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impCSIN + ) +DEFSPEC (CSQRT, + "CSQRT", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impCSQRT + ) +DEFSPEC (DABS, + "DABS", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDABS + ) +DEFSPEC (DACOS, + "DACOS", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDACOS + ) +DEFSPEC (DASIN, + "DASIN", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDASIN + ) +DEFSPEC (DATAN, + "DATAN", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDATAN + ) +DEFSPEC (DATAN2, + "DATAN2", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDATAN2 + ) +DEFSPEC (DBLE, + "DBLE", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impDBLE + ) +DEFSPEC (DCOS, + "DCOS", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDCOS + ) +DEFSPEC (DCOSH, + "DCOSH", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDCOSH + ) +DEFSPEC (DDIM, + "DDIM", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDDIM + ) +DEFSPEC (DEXP, + "DEXP", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDEXP + ) +DEFSPEC (DIM, + "DIM", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDIM + ) +DEFSPEC (DINT, + "DINT", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDINT + ) +DEFSPEC (DLOG, + "DLOG", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDLOG + ) +DEFSPEC (DLOG10, + "DLOG10", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDLOG10 + ) +DEFSPEC (DMAX1, + "DMAX1", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impDMAX1 + ) +DEFSPEC (DMIN1, + "DMIN1", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impDMIN1 + ) +DEFSPEC (DMOD, + "DMOD", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDMOD + ) +DEFSPEC (DNINT, + "DNINT", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDNINT + ) +DEFSPEC (DPROD, + "DPROD", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDPROD + ) +DEFSPEC (DSIGN, + "DSIGN", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDSIGN + ) +DEFSPEC (DSIN, + "DSIN", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDSIN + ) +DEFSPEC (DSINH, + "DSINH", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDSINH + ) +DEFSPEC (DSQRT, + "DSQRT", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDSQRT + ) +DEFSPEC (DTAN, + "DTAN", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDTAN + ) +DEFSPEC (DTANH, + "DTANH", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impDTANH + ) +DEFSPEC (EXP, + "EXP", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impEXP + ) +DEFSPEC (FLOAT, + "FLOAT", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impFLOAT + ) +DEFSPEC (IABS, + "IABS", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impIABS + ) +DEFSPEC (ICHAR, + "ICHAR", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impICHAR + ) +DEFSPEC (IDIM, + "IDIM", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impIDIM + ) +DEFSPEC (IDINT, + "IDINT", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impIDINT + ) +DEFSPEC (IDNINT, + "IDNINT", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impIDNINT + ) +DEFSPEC (IFIX, + "IFIX", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impIFIX + ) +DEFSPEC (INDEX, + "INDEX", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impINDEX + ) +DEFSPEC (INT, + "INT", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impINT + ) +DEFSPEC (ISIGN, + "ISIGN", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impISIGN + ) +DEFSPEC (LEN, + "LEN", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impLEN + ) +DEFSPEC (LGE, + "LGE", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impLGE + ) +DEFSPEC (LGT, + "LGT", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impLGT + ) +DEFSPEC (LLE, + "LLE", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impLLE + ) +DEFSPEC (LLT, + "LLT", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impLLT + ) +DEFSPEC (LOG, + "LOG", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impLOG + ) +DEFSPEC (LOG10, + "LOG10", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impLOG10 + ) +DEFSPEC (MAX, + "MAX", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impMAX + ) +DEFSPEC (MAX0, + "MAX0", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impMAX0 + ) +DEFSPEC (MAX1, + "MAX1", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impMAX1 + ) +DEFSPEC (MIN, + "MIN", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impMIN + ) +DEFSPEC (MIN0, + "MIN0", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impMIN0 + ) +DEFSPEC (MIN1, + "MIN1", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impMIN1 + ) +DEFSPEC (MOD, + "MOD", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impMOD + ) +DEFSPEC (NINT, + "NINT", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impNINT + ) +DEFSPEC (REAL, + "REAL", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impREAL + ) +DEFSPEC (SIGN, + "SIGN", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impSIGN + ) +DEFSPEC (SIN, + "SIN", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impSIN + ) +DEFSPEC (SINH, + "SINH", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impSINH + ) +DEFSPEC (SNGL, + "SNGL", + FALSE, + FFEINTRIN_familyF77, + FFEINTRIN_impSNGL + ) +DEFSPEC (SQRT, + "SQRT", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impSQRT + ) +DEFSPEC (TAN, + "TAN", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impTAN + ) +DEFSPEC (TANH, + "TANH", + TRUE, + FFEINTRIN_familyF77, + FFEINTRIN_impTANH + ) + +DEFSPEC (ABORT, + "ABORT", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impABORT + ) +DEFSPEC (ACCESS, + "ACCESS", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impACCESS +) +DEFSPEC (ACHAR, + "ACHAR", + FALSE, + FFEINTRIN_familyASC, + FFEINTRIN_impACHAR + ) +DEFSPEC (ACOSD, + "ACOSD", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (ADJUSTL, + "ADJUSTL", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (ADJUSTR, + "ADJUSTR", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (AIMAX0, + "AIMAX0", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (AIMIN0, + "AIMIN0", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (AJMAX0, + "AJMAX0", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (AJMIN0, + "AJMIN0", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (ALARM, + "ALARM", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impALARM + ) +DEFSPEC (ALL, + "ALL", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (ALLOCATED, + "ALLOCATED", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (AND, + "AND", + FALSE, + FFEINTRIN_familyF2C, + FFEINTRIN_impAND + ) +DEFSPEC (ANY, + "ANY", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (ASIND, + "ASIND", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (ASSOCIATED, + "ASSOCIATED", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (ATAN2D, + "ATAN2D", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (ATAND, + "ATAND", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (BESJ0, + "BESJ0", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impBESJ0 +) +DEFSPEC (BESJ1, + "BESJ1", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impBESJ1 +) +DEFSPEC (BESJN, + "BESJN", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impBESJN +) +DEFSPEC (BESY0, + "BESY0", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impBESY0 +) +DEFSPEC (BESY1, + "BESY1", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impBESY1 +) +DEFSPEC (BESYN, + "BESYN", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impBESYN +) +DEFSPEC (BIT_SIZE, + "BIT_SIZE", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impBIT_SIZE + ) +DEFSPEC (BITEST, + "BITEST", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (BJTEST, + "BJTEST", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (BTEST, + "BTEST", + FALSE, + FFEINTRIN_familyMIL, + FFEINTRIN_impBTEST + ) +DEFSPEC (CDABS, + "CDABS", + TRUE, + FFEINTRIN_familyFVZ, + FFEINTRIN_impCDABS + ) +DEFSPEC (CDCOS, + "CDCOS", + TRUE, + FFEINTRIN_familyFVZ, + FFEINTRIN_impCDCOS + ) +DEFSPEC (CDEXP, + "CDEXP", + TRUE, + FFEINTRIN_familyFVZ, + FFEINTRIN_impCDEXP + ) +DEFSPEC (CDLOG, + "CDLOG", + TRUE, + FFEINTRIN_familyFVZ, + FFEINTRIN_impCDLOG + ) +DEFSPEC (CDSIN, + "CDSIN", + TRUE, + FFEINTRIN_familyFVZ, + FFEINTRIN_impCDSIN + ) +DEFSPEC (CDSQRT, + "CDSQRT", + TRUE, + FFEINTRIN_familyFVZ, + FFEINTRIN_impCDSQRT + ) +DEFSPEC (CEILING, + "CEILING", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (CHDIR_func, + "function", + FALSE, + FFEINTRIN_familyBADU77, + FFEINTRIN_impCHDIR_func +) +DEFSPEC (CHDIR_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impCHDIR_subr +) +DEFSPEC (CHMOD_func, + "function", + FALSE, + FFEINTRIN_familyBADU77, + FFEINTRIN_impCHMOD_func +) +DEFSPEC (CHMOD_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impCHMOD_subr +) +DEFSPEC (COMPLEX, + "COMPLEX", + FALSE, + FFEINTRIN_familyGNU, + FFEINTRIN_impCOMPLEX + ) +DEFSPEC (COSD, + "COSD", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (COUNT, + "COUNT", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (CSHIFT, + "CSHIFT", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (CPU_TIME, + "CPU_TIME", + FALSE, + FFEINTRIN_familyF95, + FFEINTRIN_impCPU_TIME +) +DEFSPEC (CTIME_func, + "function", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impCTIME_func +) +DEFSPEC (CTIME_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impCTIME_subr +) +DEFSPEC (DACOSD, + "DACOSD", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (DASIND, + "DASIND", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (DATAN2D, + "DATAN2D", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (DATAND, + "DATAND", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (DATE, + "DATE", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impDATE +) +DEFSPEC (DATE_AND_TIME, + "DATE_AND_TIME", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (DBESJ0, + "DBESJ0", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impDBESJ0 +) +DEFSPEC (DBESJ1, + "DBESJ1", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impDBESJ1 +) +DEFSPEC (DBESJN, + "DBESJN", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impDBESJN +) +DEFSPEC (DBESY0, + "DBESY0", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impDBESY0 +) +DEFSPEC (DBESY1, + "DBESY1", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impDBESY1 +) +DEFSPEC (DBESYN, + "DBESYN", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impDBESYN +) +DEFSPEC (DBLEQ, + "DBLEQ", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (DCMPLX, + "DCMPLX", + FALSE, + FFEINTRIN_familyFVZ, + FFEINTRIN_impDCMPLX + ) +DEFSPEC (DCONJG, + "DCONJG", + TRUE, + FFEINTRIN_familyFVZ, + FFEINTRIN_impDCONJG + ) +DEFSPEC (DCOSD, + "DCOSD", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (DERF, + "DERF", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impDERF + ) +DEFSPEC (DERFC, + "DERFC", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impDERFC + ) +DEFSPEC (DFLOAT, + "DFLOAT", + FALSE, + FFEINTRIN_familyFVZ, + FFEINTRIN_impDFLOAT + ) +DEFSPEC (DFLOTI, + "DFLOTI", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (DFLOTJ, + "DFLOTJ", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (DIGITS, + "DIGITS", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (DIMAG, + "DIMAG", + TRUE, + FFEINTRIN_familyFVZ, + FFEINTRIN_impDIMAG + ) +DEFSPEC (DOT_PRODUCT, + "DOT_PRODUCT", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (DREAL, + "DREAL", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impDREAL + ) +DEFSPEC (DSIND, + "DSIND", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (DTAND, + "DTAND", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (DTIME_func, + "function", + FALSE, + FFEINTRIN_familyBADU77, + FFEINTRIN_impDTIME_func +) +DEFSPEC (DTIME_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impDTIME_subr +) +DEFSPEC (EOSHIFT, + "EOSHIFT", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (EPSILON, + "EPSILON", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (ERF, + "ERF", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impERF + ) +DEFSPEC (ERFC, + "ERFC", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impERFC + ) +DEFSPEC (ETIME_func, + "function", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impETIME_func +) +DEFSPEC (ETIME_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impETIME_subr +) +DEFSPEC (EXIT, + "EXIT", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impEXIT + ) +DEFSPEC (EXPONENT, + "EXPONENT", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (FDATE_func, + "function", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impFDATE_func +) +DEFSPEC (FDATE_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impFDATE_subr +) +DEFSPEC (FGET_func, + "function", + FALSE, + FFEINTRIN_familyBADU77, + FFEINTRIN_impFGET_func +) +DEFSPEC (FGET_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impFGET_subr +) +DEFSPEC (FGETC_func, + "function", + FALSE, + FFEINTRIN_familyBADU77, + FFEINTRIN_impFGETC_func +) +DEFSPEC (FGETC_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impFGETC_subr +) +DEFSPEC (FLOATI, + "FLOATI", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (FLOATJ, + "FLOATJ", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (FLOOR, + "FLOOR", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (FLUSH, + "FLUSH", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impFLUSH + ) +DEFSPEC (FNUM, + "FNUM", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impFNUM +) +DEFSPEC (FPUT_func, + "function", + FALSE, + FFEINTRIN_familyBADU77, + FFEINTRIN_impFPUT_func +) +DEFSPEC (FPUT_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impFPUT_subr +) +DEFSPEC (FPUTC_func, + "function", + FALSE, + FFEINTRIN_familyBADU77, + FFEINTRIN_impFPUTC_func +) +DEFSPEC (FPUTC_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impFPUTC_subr +) +DEFSPEC (FRACTION, + "FRACTION", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (FSEEK, + "FSEEK", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impFSEEK + ) +DEFSPEC (FSTAT_func, + "function", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impFSTAT_func +) +DEFSPEC (FSTAT_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impFSTAT_subr +) +DEFSPEC (FTELL_func, + "function", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impFTELL_func + ) +DEFSPEC (FTELL_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impFTELL_subr + ) +DEFSPEC (GERROR, + "GERROR", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impGERROR +) +DEFSPEC (GETARG, + "GETARG", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impGETARG + ) +DEFSPEC (GETCWD_func, + "function", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impGETCWD_func +) +DEFSPEC (GETCWD_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impGETCWD_subr +) +DEFSPEC (GETENV, + "GETENV", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impGETENV + ) +DEFSPEC (GETGID, + "GETGID", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impGETGID +) +DEFSPEC (GETLOG, + "GETLOG", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impGETLOG +) +DEFSPEC (GETPID, + "GETPID", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impGETPID +) +DEFSPEC (GETUID, + "GETUID", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impGETUID +) +DEFSPEC (GMTIME, + "GMTIME", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impGMTIME +) +DEFSPEC (HOSTNM_func, + "function", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impHOSTNM_func +) +DEFSPEC (HOSTNM_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impHOSTNM_subr +) +DEFSPEC (HUGE, + "HUGE", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (IACHAR, + "IACHAR", + FALSE, + FFEINTRIN_familyASC, + FFEINTRIN_impIACHAR + ) +DEFSPEC (IAND, + "IAND", + FALSE, + FFEINTRIN_familyMIL, + FFEINTRIN_impIAND + ) +DEFSPEC (IARGC, + "IARGC", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impIARGC + ) +DEFSPEC (IBCLR, + "IBCLR", + FALSE, + FFEINTRIN_familyMIL, + FFEINTRIN_impIBCLR + ) +DEFSPEC (IBITS, + "IBITS", + FALSE, + FFEINTRIN_familyMIL, + FFEINTRIN_impIBITS + ) +DEFSPEC (IBSET, + "IBSET", + FALSE, + FFEINTRIN_familyMIL, + FFEINTRIN_impIBSET + ) +DEFSPEC (IDATE_unix, + "UNIX", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impIDATE_unix +) +DEFSPEC (IDATE_vxt, + "VXT", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impIDATE_vxt +) +DEFSPEC (IEOR, + "IEOR", + FALSE, + FFEINTRIN_familyMIL, + FFEINTRIN_impIEOR + ) +DEFSPEC (IERRNO, + "IERRNO", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impIERRNO +) +DEFSPEC (IIABS, + "IIABS", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IIAND, + "IIAND", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IIBCLR, + "IIBCLR", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IIBITS, + "IIBITS", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IIBSET, + "IIBSET", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IIDIM, + "IIDIM", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IIDINT, + "IIDINT", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IIDNNT, + "IIDNNT", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IIEOR, + "IIEOR", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IIFIX, + "IIFIX", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IINT, + "IINT", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IIOR, + "IIOR", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IIQINT, + "IIQINT", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IIQNNT, + "IIQNNT", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IISHFT, + "IISHFT", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IISHFTC, + "IISHFTC", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IISIGN, + "IISIGN", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IMAG, + "IMAG", + FALSE, + FFEINTRIN_familyF2C, + FFEINTRIN_impIMAGPART + ) +DEFSPEC (IMAGPART, + "IMAGPART", + FALSE, + FFEINTRIN_familyGNU, + FFEINTRIN_impIMAGPART + ) +DEFSPEC (IMAX0, + "IMAX0", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IMAX1, + "IMAX1", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IMIN0, + "IMIN0", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IMIN1, + "IMIN1", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (IMOD, + "IMOD", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (ININT, + "ININT", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (INOT, + "INOT", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (INT2, + "INT2", + FALSE, + FFEINTRIN_familyGNU, + FFEINTRIN_impINT2 + ) +DEFSPEC (INT8, + "INT8", + FALSE, + FFEINTRIN_familyGNU, + FFEINTRIN_impINT8 + ) +DEFSPEC (IOR, + "IOR", + FALSE, + FFEINTRIN_familyMIL, + FFEINTRIN_impIOR + ) +DEFSPEC (IRAND, + "IRAND", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impIRAND +) +DEFSPEC (ISATTY, + "ISATTY", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impISATTY +) +DEFSPEC (ISHFT, + "ISHFT", + FALSE, + FFEINTRIN_familyMIL, + FFEINTRIN_impISHFT + ) +DEFSPEC (ISHFTC, + "ISHFTC", + FALSE, + FFEINTRIN_familyMIL, + FFEINTRIN_impISHFTC + ) +DEFSPEC (ITIME, + "ITIME", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impITIME +) +DEFSPEC (IZEXT, + "IZEXT", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JIABS, + "JIABS", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JIAND, + "JIAND", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JIBCLR, + "JIBCLR", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JIBITS, + "JIBITS", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JIBSET, + "JIBSET", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JIDIM, + "JIDIM", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JIDINT, + "JIDINT", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JIDNNT, + "JIDNNT", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JIEOR, + "JIEOR", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JIFIX, + "JIFIX", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JINT, + "JINT", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JIOR, + "JIOR", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JIQINT, + "JIQINT", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JIQNNT, + "JIQNNT", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JISHFT, + "JISHFT", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JISHFTC, + "JISHFTC", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JISIGN, + "JISIGN", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JMAX0, + "JMAX0", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JMAX1, + "JMAX1", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JMIN0, + "JMIN0", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JMIN1, + "JMIN1", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JMOD, + "JMOD", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JNINT, + "JNINT", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JNOT, + "JNOT", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (JZEXT, + "JZEXT", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (KILL_func, + "function", + FALSE, + FFEINTRIN_familyBADU77, + FFEINTRIN_impKILL_func +) +DEFSPEC (KILL_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impKILL_subr +) +DEFSPEC (KIND, + "KIND", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (LBOUND, + "LBOUND", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (LINK_func, + "function", + FALSE, + FFEINTRIN_familyBADU77, + FFEINTRIN_impLINK_func +) +DEFSPEC (LINK_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impLINK_subr +) +DEFSPEC (LEN_TRIM, + "LEN_TRIM", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impLNBLNK + ) +DEFSPEC (LNBLNK, + "LNBLNK", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impLNBLNK +) +DEFSPEC (LOC, + "LOC", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impLOC + ) +DEFSPEC (LOGICAL, + "LOGICAL", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (LONG, + "LONG", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impLONG + ) +DEFSPEC (LSHIFT, + "LSHIFT", + FALSE, + FFEINTRIN_familyF2C, + FFEINTRIN_impLSHIFT + ) +DEFSPEC (LSTAT_func, + "function", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impLSTAT_func +) +DEFSPEC (LSTAT_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impLSTAT_subr +) +DEFSPEC (LTIME, + "LTIME", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impLTIME +) +DEFSPEC (MATMUL, + "MATMUL", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (MAXEXPONENT, + "MAXEXPONENT", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (MAXLOC, + "MAXLOC", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (MAXVAL, + "MAXVAL", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (MCLOCK, + "MCLOCK", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impMCLOCK +) +DEFSPEC (MCLOCK8, + "MCLOCK8", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impMCLOCK8 +) +DEFSPEC (MERGE, + "MERGE", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (MINEXPONENT, + "MINEXPONENT", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (MINLOC, + "MINLOC", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (MINVAL, + "MINVAL", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (MODULO, + "MODULO", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (MVBITS, + "MVBITS", + FALSE, + FFEINTRIN_familyMIL, + FFEINTRIN_impMVBITS + ) +DEFSPEC (NEAREST, + "NEAREST", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (NOT, + "NOT", + FALSE, + FFEINTRIN_familyMIL, + FFEINTRIN_impNOT + ) +DEFSPEC (OR, + "OR", + FALSE, + FFEINTRIN_familyF2C, + FFEINTRIN_impOR + ) +DEFSPEC (PACK, + "PACK", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (PERROR, + "PERROR", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impPERROR +) +DEFSPEC (PRECISION, + "PRECISION", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (PRESENT, + "PRESENT", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (PRODUCT, + "PRODUCT", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (QABS, + "QABS", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QACOS, + "QACOS", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QACOSD, + "QACOSD", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QASIN, + "QASIN", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QASIND, + "QASIND", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QATAN, + "QATAN", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QATAN2, + "QATAN2", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QATAN2D, + "QATAN2D", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QATAND, + "QATAND", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QCOS, + "QCOS", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QCOSD, + "QCOSD", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QCOSH, + "QCOSH", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QDIM, + "QDIM", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QEXP, + "QEXP", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QEXT, + "QEXT", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QEXTD, + "QEXTD", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QFLOAT, + "QFLOAT", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QINT, + "QINT", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QLOG, + "QLOG", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QLOG10, + "QLOG10", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QMAX1, + "QMAX1", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QMIN1, + "QMIN1", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QMOD, + "QMOD", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QNINT, + "QNINT", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QSIGN, + "QSIGN", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QSIN, + "QSIN", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QSIND, + "QSIND", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QSINH, + "QSINH", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QSQRT, + "QSQRT", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QTAN, + "QTAN", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QTAND, + "QTAND", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (QTANH, + "QTANH", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (RADIX, + "RADIX", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (RAND, + "RAND", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impRAND +) +DEFSPEC (RANDOM_NUMBER, + "RANDOM_NUMBER", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (RANDOM_SEED, + "RANDOM_SEED", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (RANGE, + "RANGE", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (REALPART, + "REALPART", + FALSE, + FFEINTRIN_familyGNU, + FFEINTRIN_impREALPART + ) +DEFSPEC (RENAME_func, + "function", + FALSE, + FFEINTRIN_familyBADU77, + FFEINTRIN_impRENAME_func +) +DEFSPEC (RENAME_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impRENAME_subr +) +DEFSPEC (REPEAT, + "REPEAT", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (RESHAPE, + "RESHAPE", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (RRSPACING, + "RRSPACING", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (RSHIFT, + "RSHIFT", + FALSE, + FFEINTRIN_familyF2C, + FFEINTRIN_impRSHIFT + ) +DEFSPEC (SCALE, + "SCALE", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (SCAN, + "SCAN", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (SECNDS, + "SECNDS", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impSECNDS +) +DEFSPEC (SECOND_func, + "function", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impSECOND_func +) +DEFSPEC (SECOND_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impSECOND_subr +) +DEFSPEC (SEL_INT_KIND, + "SEL_INT_KIND", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (SEL_REAL_KIND, + "SEL_REAL_KIND", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (SET_EXPONENT, + "SET_EXPONENT", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (SHAPE, + "SHAPE", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (SHORT, + "SHORT", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impSHORT + ) +DEFSPEC (SIGNAL_func, + "function", + FALSE, + FFEINTRIN_familyBADU77, + FFEINTRIN_impSIGNAL_func + ) +DEFSPEC (SIGNAL_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impSIGNAL_subr + ) +DEFSPEC (SIND, + "SIND", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (SLEEP, + "SLEEP", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impSLEEP +) +DEFSPEC (SNGLQ, + "SNGLQ", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (SPACING, + "SPACING", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (SPREAD, + "SPREAD", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (SRAND, + "SRAND", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impSRAND +) +DEFSPEC (STAT_func, + "function", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impSTAT_func +) +DEFSPEC (STAT_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impSTAT_subr +) +DEFSPEC (SUM, + "SUM", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (SYMLNK_func, + "function", + FALSE, + FFEINTRIN_familyBADU77, + FFEINTRIN_impSYMLNK_func +) +DEFSPEC (SYMLNK_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impSYMLNK_subr +) +DEFSPEC (SYSTEM_func, + "function", + FALSE, + FFEINTRIN_familyBADU77, + FFEINTRIN_impSYSTEM_func + ) +DEFSPEC (SYSTEM_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impSYSTEM_subr + ) +DEFSPEC (SYSTEM_CLOCK, + "SYSTEM_CLOCK", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impSYSTEM_CLOCK + ) +DEFSPEC (TAND, + "TAND", + TRUE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (TIME8, + "UNIX", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impTIME8 +) +DEFSPEC (TIME_unix, + "UNIX", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impTIME_unix +) +DEFSPEC (TIME_vxt, + "VXT", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impTIME_vxt +) +DEFSPEC (TINY, + "TINY", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (TRANSFER, + "TRANSFER", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (TRANSPOSE, + "TRANSPOSE", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (TRIM, + "TRIM", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (TTYNAM_func, + "function", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impTTYNAM_func +) +DEFSPEC (TTYNAM_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impTTYNAM_subr +) +DEFSPEC (UBOUND, + "UBOUND", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (UMASK_func, + "function", + FALSE, + FFEINTRIN_familyBADU77, + FFEINTRIN_impUMASK_func +) +DEFSPEC (UMASK_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impUMASK_subr +) +DEFSPEC (UNLINK_func, + "function", + FALSE, + FFEINTRIN_familyBADU77, + FFEINTRIN_impUNLINK_func +) +DEFSPEC (UNLINK_subr, + "subroutine", + FALSE, + FFEINTRIN_familyF2U, + FFEINTRIN_impUNLINK_subr +) +DEFSPEC (UNPACK, + "UNPACK", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (VERIFY, + "VERIFY", + FALSE, + FFEINTRIN_familyF90, + FFEINTRIN_impNONE + ) +DEFSPEC (XOR, + "XOR", + FALSE, + FFEINTRIN_familyF2C, + FFEINTRIN_impXOR + ) +DEFSPEC (ZABS, + "ZABS", + TRUE, + FFEINTRIN_familyF2C, + FFEINTRIN_impCDABS + ) +DEFSPEC (ZCOS, + "ZCOS", + TRUE, + FFEINTRIN_familyF2C, + FFEINTRIN_impCDCOS + ) +DEFSPEC (ZEXP, + "ZEXP", + TRUE, + FFEINTRIN_familyF2C, + FFEINTRIN_impCDEXP + ) +DEFSPEC (ZEXT, + "ZEXT", + FALSE, + FFEINTRIN_familyVXT, + FFEINTRIN_impNONE + ) +DEFSPEC (ZLOG, + "ZLOG", + TRUE, + FFEINTRIN_familyF2C, + FFEINTRIN_impCDLOG + ) +DEFSPEC (ZSIN, + "ZSIN", + TRUE, + FFEINTRIN_familyF2C, + FFEINTRIN_impCDSIN + ) +DEFSPEC (ZSQRT, + "ZSQRT", + TRUE, + FFEINTRIN_familyF2C, + FFEINTRIN_impCDSQRT + ) +DEFSPEC (NONE, + "none", + FALSE, + FFEINTRIN_familyNONE, + FFEINTRIN_impNONE + ) + +/* Intrinsic implementations ordered in two sections: + F77, then extensions; secondarily, alphabetical + ordering. */ + +/* The DEFIMP macro specifies the following fields for an intrinsic: + + CODE -- The internal name for this intrinsic; `FFEINTRIN_imp' + prepends this to form the `enum' name. + + NAME -- The textual name to use when printing information on + this intrinsic. + + GFRTDIRECT -- The run-time library routine that is suitable for + a call to implement a *direct* invocation of the + intrinsic (e.g. `ABS(10)'). + + GFRTF2C -- The run-time library routine that is suitable for + passing as an argument to a procedure that will + invoke the argument as an EXTERNAL procedure, when + f2c calling conventions will be used (e.g. + `CALL FOO(ABS)', when FOO compiled with -ff2c). + + GFRTGNU -- The run-time library routine that is suitable for + passing as an argument to a procedure that will + invoke the argument as an EXTERNAL procedure, when + GNU calling conventions will be used (e.g. + `CALL FOO(ABS)', when FOO compiled with -fno-f2c). + + CONTROL -- A control string, described below. + +*/ + +/* The control string has the following format: + + ::[,...] + + is: + + [] + + is: + + - Subroutine + A Character + C Complex + I Integer + L Logical + R Real + B Boolean (I or L), decided by co-operand list (COL) + F Floating-point (C or R), decided by COL + N Numeric (C, I, or R), decided by co-operand list (COL) + S Scalar numeric (I or R), decided by COL, which may be COMPLEX + + is: + + - Subroutine + = Decided by COL + 1 (Default) + 2 (Twice the size of 1) + 3 (Same size as CHARACTER*1) + 4 (Twice the size of 2) + 6 (Twice the size as 3) + C Like 1 (F77), except (F90), if COL is COMPLEX, uses kind type of COL + p ffecom_pointer_kind_ + + is: + + * Valid for of `A' only, means program may + declare any length for return value, default being (*) + + is: + + + + is: + + - No COL (return-base-type and return-kind-type must be definitive) + * All arguments form COL (must have more than one argument) + n Argument n (0 for first arg, 1 for second, etc.) forms COL + + is: + + =[][][][] + + is the standard keyword name for the argument. + + is: + + ? Argument is optional + ! Like ?, but argument must be omitted if previous arg was COMPLEX + + One or more of these arguments must be specified + * Zero or more of these arguments must be specified + n Numbered names for arguments, one or more must be specified + p Like n, but two or more must be specified + + is: + + - Any is valid (arg-kind-type is 0) + A Character*(*) + C Complex + I Integer + L Logical + R Real + B Boolean (I or L) + F Floating-point (C or R) + N Numeric (C, I, or R) + S Scalar numeric (I or R) + g GOTO label (alternate-return form of CALL) (arg-kind-type is 0) + s Signal handler (INTEGER FUNCTION, SUBROUTINE or dummy/global + default INTEGER variable) (arg-kind-type is 0) + + is: + + * Any is valid + 1 (Default) + 2 (Twice the size of 1) + 3 (Same size as CHARACTER*1) + 4 (Twice the size of 2) + 6 (Twice the size as 3) + A Same as first argument + + is: + + (Default) CHARACTER*(*) + [n] CHARACTER*n + + is: + + (default) Rank-0 (variable or array element) + (n) Rank-1 array n elements long + & Any (arg-extra is &) + + is: + + (default) Arg is INTENT(IN) + i Arg's attributes are all that matter (inquiry function) + w Arg is INTENT(OUT) + x Arg is INTENT(INOUT) + & Arg can have its address taken (LOC(), for example) + +*/ + +DEFIMP (ABS, "ABS", ,ABS,, "S=:0:A=N*") +DEFIMP (ACOS, "ACOS", L_ACOS,ACOS,, "R=:0:X=R*") +DEFIMP (AIMAG, "AIMAG", ,AIMAG,, "RC:0:Z=C*") +DEFIMP (AINT, "AINT", ,AINT,, "R=:0:A=R*") +DEFIMP (ALOG, "ALOG", L_LOG,ALOG,, "R1:-:X=R1") +DEFIMP (ALOG10, "ALOG10", ,ALOG10,, "R1:-:X=R1") +DEFIMP (AMAX0, "AMAX0", ,,, "R1:*:A=pI1") +DEFIMP (AMAX1, "AMAX1", ,,, "R1:*:A=pR1") +DEFIMP (AMIN0, "AMIN0", ,,, "R1:*:A=pI1") +DEFIMP (AMIN1, "AMIN1", ,,, "R1:*:A=pR1") +DEFIMP (AMOD, "AMOD", ,AMOD,, "R1:*:A=R1,P=R1") +DEFIMP (ANINT, "ANINT", ,ANINT,, "R=:0:A=R*") +DEFIMP (ASIN, "ASIN", L_ASIN,ASIN,, "R=:0:X=R*") +DEFIMP (ATAN, "ATAN", L_ATAN,ATAN,, "R=:0:X=R*") +DEFIMP (ATAN2, "ATAN2", L_ATAN2,ATAN2,, "R=:*:Y=R*,X=R*") +DEFIMP (CABS, "CABS", ,CABS,, "R1:-:A=C1") +DEFIMP (CCOS, "CCOS", ,CCOS,, "C1:-:X=C1") +DEFIMP (CEXP, "CEXP", ,CEXP,, "C1:-:X=C1") +DEFIMP (CHAR, "CHAR", ,,, "A1:-:I=I*") +DEFIMP (CLOG, "CLOG", ,CLOG,, "C1:-:X=C1") +DEFIMP (CMPLX, "CMPLX", ,,, "C1:*:X=N*,Y=!S*") +DEFIMP (CONJG, "CONJG", ,CONJG,, "C=:0:Z=C*") +DEFIMP (COS, "COS", L_COS,COS,, "F=:0:X=F*") +DEFIMP (COSH, "COSH", L_COSH,COSH,, "R=:0:X=R*") +DEFIMP (CSIN, "CSIN", ,CSIN,, "C1:-:X=C1") +DEFIMP (CSQRT, "CSQRT", ,CSQRT,, "C1:-:X=C1") +DEFIMP (DABS, "DABS", ,DABS,, "R2:-:A=R2") +DEFIMP (DACOS, "DACOS", L_ACOS,DACOS,, "R2:-:X=R2") +DEFIMP (DASIN, "DASIN", L_ASIN,DASIN,, "R2:-:X=R2") +DEFIMP (DATAN, "DATAN", L_ATAN,DATAN,, "R2:-:X=R2") +DEFIMP (DATAN2, "DATAN2", L_ATAN2,DATAN2,,"R2:*:Y=R2,X=R2") +DEFIMP (DBLE, "DBLE", ,,, "R2:-:A=N*") +DEFIMP (DCMPLX, "DCMPLX", ,,, "C2:*:X=N*,Y=!S*") +DEFIMP (DCOS, "DCOS", L_COS,DCOS,, "R2:-:X=R2") +DEFIMP (DCOSH, "DCOSH", L_COSH,DCOSH,, "R2:-:X=R2") +DEFIMP (DDIM, "DDIM", ,DDIM,, "R2:*:X=R2,Y=R2") +DEFIMP (DEXP, "DEXP", L_EXP,DEXP,, "R2:-:X=R2") +DEFIMP (DIM, "DIM", ,DIM,, "S=:*:X=S*,Y=S*") +DEFIMP (DINT, "DINT", ,DINT,, "R2:-:A=R2") +DEFIMP (DLOG, "DLOG", L_LOG,DLOG,, "R2:-:X=R2") +DEFIMP (DLOG10, "DLOG10", ,DLOG10,, "R2:-:X=R2") +DEFIMP (DMAX1, "DMAX1", ,,, "R2:*:A=pR2") +DEFIMP (DMIN1, "DMIN1", ,,, "R2:*:A=pR2") +DEFIMP (DMOD, "DMOD", ,DMOD,, "R2:*:A=R2,P=R2") +DEFIMP (DNINT, "DNINT", ,DNINT,, "R2:-:A=R2") +DEFIMP (DPROD, "DPROD", ,DPROD,, "R2:*:X=R1,Y=R1") +DEFIMP (DSIGN, "DSIGN", ,DSIGN,, "R2:*:A=R2,B=R2") +DEFIMP (DSIN, "DSIN", L_SIN,DSIN,, "R2:-:X=R2") +DEFIMP (DSINH, "DSINH", L_SINH,DSINH,, "R2:-:X=R2") +DEFIMP (DSQRT, "DSQRT", L_SQRT,DSQRT,, "R2:-:X=R2") +DEFIMP (DTAN, "DTAN", L_TAN,DTAN,, "R2:-:X=R2") +DEFIMP (DTANH, "DTANH", L_TANH,DTANH,, "R2:-:X=R2") +DEFIMP (EXP, "EXP", L_EXP,EXP,, "F=:0:X=F*") +DEFIMP (FLOAT, "FLOAT", ,,, "R1:-:A=I*") +DEFIMP (IABS, "IABS", ,IABS,IABS, "I1:-:A=I1") +DEFIMP (ICHAR, "ICHAR", ,,, "I1:-:C=A*") +DEFIMP (IDIM, "IDIM", ,IDIM,IDIM, "I1:*:X=I1,Y=I1") +DEFIMP (IDINT, "IDINT", ,,, "I1:-:A=R2") +DEFIMP (IDNINT, "IDNINT", ,IDNINT,IDNINT, "I1:-:A=R2") +DEFIMP (IFIX, "IFIX", ,,, "I1:-:A=R1") +DEFIMP (INDEX, "INDEX", ,INDEX,INDEX, "I1:*:String=A*,Substring=A*") +DEFIMP (INT, "INT", ,,, "I1:-:A=N*") +DEFIMP (ISIGN, "ISIGN", ,ISIGN,ISIGN, "I1:*:A=I1,B=I1") +DEFIMP (LEN, "LEN", ,LEN,LEN, "I1:-:String=A*i") +DEFIMP (LGE, "LGE", ,LGE,LGE, "L1:*:String_A=A1,String_B=A1") +DEFIMP (LGT, "LGT", ,LGT,LGT, "L1:*:String_A=A1,String_B=A1") +DEFIMP (LLE, "LLE", ,LLE,LLE, "L1:*:String_A=A1,String_B=A1") +DEFIMP (LLT, "LLT", ,LLT,LLT, "L1:*:String_A=A1,String_B=A1") +DEFIMP (LOG, "LOG", L_LOG,ALOG,, "F=:0:X=F*") +DEFIMP (LOG10, "LOG10", ,,, "R=:0:X=R*") +DEFIMP (MAX, "MAX", ,,, "S=:*:A=pS*") +DEFIMP (MIN, "MIN", ,,, "S=:*:A=pS*") +DEFIMP (MAX0, "MAX0", ,,, "I1:*:A=pI1") +DEFIMP (MAX1, "MAX1", ,,, "I1:*:A=pR1") +DEFIMP (MIN0, "MIN0", ,,, "I1:*:A=pI1") +DEFIMP (MIN1, "MIN1", ,,, "I1:*:A=pR1") +DEFIMP (MOD, "MOD", ,MOD,MOD, "S=:*:A=S*,P=S*") +DEFIMP (NINT, "NINT", ,NINT,NINT, "I1:-:A=R*") +DEFIMP (REAL, "REAL", ,,, "RC:0:A=N*") +DEFIMP (SIGN, "SIGN", ,SIGN,, "S=:*:A=S*,B=S*") +DEFIMP (SIN, "SIN", L_SIN,SIN,, "F=:0:X=F*") +DEFIMP (SINH, "SINH", L_SINH,SINH,, "R=:0:X=R*") +DEFIMP (SNGL, "SNGL", ,,, "R1:-:A=R2") +DEFIMP (SQRT, "SQRT", L_SQRT,SQRT,, "F=:0:X=F*") +DEFIMP (TAN, "TAN", L_TAN,TAN,, "R=:0:X=R*") +DEFIMP (TANH, "TANH", L_TANH,TANH,, "R=:0:X=R*") + +DEFIMP (ABORT, "ABORT", ABORT,,, "--:-:") +DEFIMP (ACCESS, "ACCESS", ACCESS,,, "I1:-:Name=A1,Mode=A1") +DEFIMP (ACHAR, "ACHAR", ,,, "A1:-:I=I*") +DEFIMP (ALARM, "ALARM", ALARM,,, "--:-:Seconds=I*,Handler=s*,Status=?I1w") +DEFIMP (AND, "AND", ,,, "B=:*:I=B*,J=B*") +DEFIMP (BESJ0, "BESJ0", L_BESJ0,,, "R=:0:X=R*") +DEFIMP (BESJ1, "BESJ1", L_BESJ1,,, "R=:0:X=R*") +DEFIMP (BESJN, "BESJN", L_BESJN,,, "R=:1:N=I*,X=R*") +DEFIMP (BESY0, "BESY0", L_BESY0,,, "R=:0:X=R*") +DEFIMP (BESY1, "BESY1", L_BESY1,,, "R=:0:X=R*") +DEFIMP (BESYN, "BESYN", L_BESYN,,, "R=:1:N=I*,X=R*") +DEFIMP (BIT_SIZE, "BIT_SIZE", ,,, "I=:0:I=I*i") +DEFIMP (BTEST, "BTEST", ,,, "L1:*:I=I*,Pos=I*") +DEFIMP (CDABS, "CDABS", ,CDABS,, "R2:-:A=C2") +DEFIMP (CDCOS, "CDCOS", ,CDCOS,, "C2:-:X=C2") +DEFIMP (CDEXP, "CDEXP", ,CDEXP,, "C2:-:X=C2") +DEFIMP (CDLOG, "CDLOG", ,CDLOG,, "C2:-:X=C2") +DEFIMP (CDSIN, "CDSIN", ,CDSIN,, "C2:-:X=C2") +DEFIMP (CDSQRT, "CDSQRT", ,CDSQRT,, "C2:-:X=C2") +DEFIMP (CHDIR_func, "CHDIR_func", CHDIR,,, "I1:-:Dir=A1") +DEFIMP (CHDIR_subr, "CHDIR_subr", CHDIR,,, "--:-:Dir=A1,Status=?I1w") +DEFIMP (CHMOD_func, "CHMOD_func", CHMOD,,, "I1:-:Name=A1,Mode=A1") +DEFIMP (CHMOD_subr, "CHMOD_subr", CHMOD,,, "--:-:Name=A1,Mode=A1,Status=?I1w") +DEFIMP (COMPLEX, "COMPLEX", ,,, "C=:*:Real=S*,Imag=S*") +DEFIMP (CPU_TIME, "CPU_TIME", ,,, "--:-:Seconds=R1w") +DEFIMP (CTIME_func, "CTIME_func", CTIME,,, "A1*:-:STime=I*") +DEFIMP (CTIME_subr, "CTIME_subr", CTIME,,, "--:-:Result=A1w,STime=I*") +DEFIMP (DATE, "DATE", DATE,,, "--:-:Date=A1w") +DEFIMP (DBESJ0, "DBESJ0", L_BESJ0,,, "R2:-:X=R2") +DEFIMP (DBESJ1, "DBESJ1", L_BESJ1,,, "R2:-:X=R2") +DEFIMP (DBESJN, "DBESJN", L_BESJN,,, "R2:-:N=I*,X=R2") +DEFIMP (DBESY0, "DBESY0", L_BESY0,,, "R2:-:X=R2") +DEFIMP (DBESY1, "DBESY1", L_BESY1,,, "R2:-:X=R2") +DEFIMP (DBESYN, "DBESYN", L_BESYN,,, "R2:-:N=I*,X=R2") +DEFIMP (DCONJG, "DCONJG", ,DCONJG,, "C2:-:Z=C2") +DEFIMP (DERF, "DERF", L_ERF,DERF,, "R2:-:X=R2") +DEFIMP (DERFC, "DERFC", L_ERFC,DERFC,, "R2:-:X=R2") +DEFIMP (DFLOAT, "DFLOAT", ,,, "R2:-:A=I*") +DEFIMP (DIMAG, "DIMAG", ,DIMAG,, "R2:-:Z=C2") +DEFIMP (DREAL, "DREAL", ,,, "R2:-:A=N*") +DEFIMP (DTIME_func, "DTIME_func", DTIME,,, "R1:-:TArray=R1(2)w") +DEFIMP (DTIME_subr, "DTIME_subr", DTIME,,, "--:-:Result=R1w,TArray=R1(2)w") +DEFIMP (ERF, "ERF", L_ERF,ERF,, "R=:0:X=R*") +DEFIMP (ERFC, "ERFC", L_ERFC,ERFC,, "R=:0:X=R*") +DEFIMP (ETIME_func, "ETIME_func", ETIME,,, "R1:-:TArray=R1(2)w") +DEFIMP (ETIME_subr, "ETIME_subr", ETIME,,, "--:-:Result=R1w,TArray=R1(2)w") +DEFIMP (EXIT, "EXIT", EXIT,,, "--:-:Status=?I*") +DEFIMP (FDATE_func, "FDATE_func", FDATE,,, "A1*:-:") +DEFIMP (FDATE_subr, "FDATE_subr", FDATE,,, "--:-:Date=A1w") +DEFIMP (FGET_func, "FGET_func", FGET,,, "I1:-:C=A1w") +DEFIMP (FGET_subr, "FGET_subr", FGET,,, "--:-:C=A1w,Status=?I1w") +DEFIMP (FGETC_func, "FGETC_func", FGETC,,, "I1:-:Unit=I*,C=A1w") +DEFIMP (FGETC_subr, "FGETC_subr", FGETC,,, "--:-:Unit=I*,C=A1w,Status=?I1w") +DEFIMP (FLUSH, "FLUSH", ,,, "--:-:Unit=?I*") +DEFIMP (FNUM, "FNUM", FNUM,,, "I1:-:Unit=I*") +DEFIMP (FPUT_func, "FPUT_func", FPUT,,, "I1:-:C=A1") +DEFIMP (FPUT_subr, "FPUT_subr", FPUT,,, "--:-:C=A1,Status=?I1w") +DEFIMP (FPUTC_func, "FPUTC_func", FPUTC,,, "I1:-:Unit=I*,C=A1") +DEFIMP (FPUTC_subr, "FPUTC_subr", FPUTC,,, "--:-:Unit=I*,C=A1,Status=?I1w") +DEFIMP (FSEEK, "FSEEK", FSEEK,,, "--:-:Unit=I*,Offset=I*,Whence=I*,ErrLab=?g*") +DEFIMP (FSTAT_func, "FSTAT_func", FSTAT,,, "I1:-:Unit=I*,SArray=I1(13)w") +DEFIMP (FSTAT_subr, "FSTAT_subr", FSTAT,,, "--:-:Unit=I*,SArray=I1(13)w,Status=?I1w") +DEFIMP (FTELL_func, "FTELL_func", FTELL,,, "I1:-:Unit=I*") +DEFIMP (FTELL_subr, "FTELL_subr", FTELL,,, "--:-:Unit=I*,Offset=I1w") +DEFIMP (GERROR, "GERROR", GERROR,,, "--:-:Message=A1w") +DEFIMP (GETARG, "GETARG", GETARG,,, "--:-:Pos=I*,Value=A1w") +DEFIMP (GETCWD_func, "GETCWD_func", GETCWD,,, "I1:-:Name=A1w") +DEFIMP (GETCWD_subr, "GETCWD_subr", GETCWD,,, "--:-:Name=A1w,Status=?I1w") +DEFIMP (GETGID, "GETGID", GETGID,,, "I1:-:") +DEFIMP (GETLOG, "GETLOG", GETLOG,,, "--:-:Login=A1w") +DEFIMP (GETPID, "GETPID", GETPID,,, "I1:-:") +DEFIMP (GETUID, "GETUID", GETUID,,, "I1:-:") +DEFIMP (GETENV, "GETENV", GETENV,,, "--:-:Name=A1,Value=A1w") +DEFIMP (GMTIME, "GMTIME", GMTIME,,, "--:-:STime=I1,TArray=I1(9)w") +DEFIMP (HOSTNM_func, "HOSTNM_func", HOSTNM,,, "I1:-:Name=A1w") +DEFIMP (HOSTNM_subr, "HOSTNM_subr", HOSTNM,,, "--:-:Name=A1w,Status=?I1w") +DEFIMP (IACHAR, "IACHAR", ,,, "I1:-:C=A*") +DEFIMP (IAND, "IAND", ,,, "I=:*:I=I*,J=I*") +DEFIMP (IARGC, "IARGC", IARGC,,, "I1:-:") +DEFIMP (IBCLR, "IBCLR", ,,, "I=:0:I=I*,Pos=I*") +DEFIMP (IBITS, "IBITS", ,,, "I=:0:I=I*,Pos=I*,Len=I*") +DEFIMP (IBSET, "IBSET", ,,, "I=:0:I=I*,Pos=I*") +DEFIMP (IDATE_unix, "IDATE_unix", IDATE,,, "--:-:TArray=I1(3)w") +DEFIMP (IDATE_vxt, "IDATE_vxt", VXTIDATE,,, "--:-:M=I1w,D=I1w,Y=I1w") +DEFIMP (IEOR, "IEOR", ,,, "I=:*:I=I*,J=I*") +DEFIMP (IOR, "IOR", ,,, "I=:*:I=I*,J=I*") +DEFIMP (IERRNO, "IERRNO", IERRNO,,, "I1:-:") +DEFIMP (IMAGPART, "IMAGPART", ,,, "R=:0:Z=C*") +DEFIMP (INT2, "INT2", ,,, "I6:-:A=I*") +DEFIMP (INT8, "INT8", ,,, "I2:-:A=I*") +DEFIMP (IRAND, "IRAND", IRAND,,, "I1:-:Flag=?I*") +DEFIMP (ISATTY, "ISATTY", ISATTY,,, "L1:-:Unit=I*") +DEFIMP (ISHFT, "ISHFT", ,,, "I=:0:I=I*,Shift=I*") +DEFIMP (ISHFTC, "ISHFTC", ,,, "I=:0:I=I*,Shift=I*,Size=I*") +DEFIMP (ITIME, "ITIME", ITIME,,, "--:-:TArray=I1(3)w") +DEFIMP (KILL_func, "KILL_func", KILL,,, "I1:-:Pid=I*,Signal=I*") +DEFIMP (KILL_subr, "KILL_subr", KILL,,, "--:-:Pid=I*,Signal=I*,Status=?I1w") +DEFIMP (LINK_func, "LINK_func", LINK,,, "I1:-:Path1=A1,Path2=A1") +DEFIMP (LINK_subr, "LINK_subr", LINK,,, "--:-:Path1=A1,Path2=A1,Status=?I1w") +DEFIMP (LNBLNK, "LNBLNK", LNBLNK,,, "I1:-:String=A1") +DEFIMP (LONG, "LONG", ,,, "I1:-:A=I6") +DEFIMP (LSTAT_func, "LSTAT_func", LSTAT,,, "I1:-:File=A1,SArray=I1(13)w") +DEFIMP (LSTAT_subr, "LSTAT_subr", LSTAT,,, "--:-:File=A1,SArray=I1(13)w,Status=?I1w") +DEFIMP (LTIME, "LTIME", LTIME,,, "--:-:STime=I1,TArray=I1(9)w") +DEFIMP (LOC, "LOC", ,,, "Ip:-:Entity=-*&&") +DEFIMP (LSHIFT, "LSHIFT", ,,, "I=:0:I=I*,Shift=I*") +DEFIMP (MCLOCK, "MCLOCK", MCLOCK,,, "I1:-:") +DEFIMP (MCLOCK8, "MCLOCK8", MCLOCK,,, "I2:-:") +DEFIMP (MVBITS, "MVBITS", ,,, "--:-:From=I*,FromPos=I*,Len=I*,TO=IAx,ToPos=I*") +DEFIMP (NOT, "NOT", ,,, "I=:0:I=I*") +DEFIMP (OR, "OR", ,,, "B=:*:I=B*,J=B*") +DEFIMP (PERROR, "PERROR", PERROR,,, "--:-:String=A1") +DEFIMP (RAND, "RAND", RAND,,, "R1:-:Flag=?I*") +DEFIMP (REALPART, "REALPART", ,,, "R=:0:Z=C*") +DEFIMP (RENAME_func, "RENAME_func", RENAME,,, "I1:-:Path1=A1,Path2=A1") +DEFIMP (RENAME_subr, "RENAME_subr", RENAME,,, "--:-:Path1=A1,Path2=A1,Status=?I1w") +DEFIMP (RSHIFT, "RSHIFT", ,,, "I=:0:I=I*,Shift=I*") +DEFIMP (SECNDS, "SECNDS", SECNDS,,, "R1:-:T=R1") +DEFIMP (SECOND_func, "SECOND_func", SECOND,SECOND,, "R1:-:") +DEFIMP (SECOND_subr, "SECOND_subr", SECOND,,, "--:-:Seconds=R1w") +DEFIMP (SHORT, "SHORT", ,,, "I6:-:A=I*") +DEFIMP (SIGNAL_func, "SIGNAL_func", L_SIGNAL,,, "I1:-:Number=I*,Handler=s*") +DEFIMP (SIGNAL_subr, "SIGNAL_subr", L_SIGNAL,,, "--:-:Number=I*,Handler=s*,Status=?I1w") +DEFIMP (SLEEP, "SLEEP", SLEEP,,, "--:-:Seconds=I1") +DEFIMP (SRAND, "SRAND", SRAND,,, "--:-:Seed=I*") +DEFIMP (STAT_func, "STAT_func", STAT,,, "I1:-:File=A1,SArray=I1(13)w") +DEFIMP (STAT_subr, "STAT_subr", STAT,,, "--:-:File=A1,SArray=I1(13)w,Status=?I1w") +DEFIMP (SYMLNK_func, "SYMLNK_func", SYMLNK,,, "I1:-:Path1=A1,Path2=A1") +DEFIMP (SYMLNK_subr, "SYMLNK_subr", SYMLNK,,, "--:-:Path1=A1,Path2=A1,Status=?I1w") +DEFIMP (SYSTEM_func, "SYSTEM_func", SYSTEM,SYSTEM,SYSTEM,"I1:-:Command=A1") +DEFIMP (SYSTEM_subr, "SYSTEM_subr", SYSTEM,,, "--:-:Command=A1,Status=?I1w") +DEFIMP (SYSTEM_CLOCK, "SYSTEM_CLOCK", SYSTEM_CLOCK,,, "--:-:Count=I1w,Rate=I1w,Max=I1w") +DEFIMP (TIME8, "TIME8", TIME,,, "I2:-:") +DEFIMP (TIME_unix, "TIME_unix", TIME,,, "I1:-:") +DEFIMP (TIME_vxt, "TIME_vxt", VXTTIME,,, "--:-:Time=A1[8]w") +DEFIMP (TTYNAM_func, "TTYNAM_func", TTYNAM,,, "A1*:-:Unit=I*") +DEFIMP (TTYNAM_subr, "TTYNAM_subr", TTYNAM,,, "--:-:Name=A1w,Unit=I*") +DEFIMP (UMASK_func, "UMASK_func", UMASK,,, "I1:-:Mask=I*") +DEFIMP (UMASK_subr, "UMASK_subr", UMASK,,, "--:-:Mask=I*,Old=?I1w") +DEFIMP (UNLINK_func, "UNLINK_func", UNLINK,,, "I1:-:File=A1") +DEFIMP (UNLINK_subr, "UNLINK_subr", UNLINK,,, "--:-:File=A1,Status=?I1w") +DEFIMP (XOR, "XOR", ,,, "B=:*:I=B*,J=B*") +DEFIMP (NONE, "none", ,,, "") diff --git a/gcc/f/intrin.h b/gcc/f/intrin.h new file mode 100644 index 000000000000..c19b0fd85dd1 --- /dev/null +++ b/gcc/f/intrin.h @@ -0,0 +1,130 @@ +/* intrin.h -- Public interface for intrin.c + Copyright (C) 1995, 1996 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + +*/ + +#ifndef _H_f_intrin +#define _H_f_intrin + +#ifndef FFEINTRIN_DOC +#define FFEINTRIN_DOC 0 /* 1 means intrinsic documentation only (intdoc.c). */ +#endif + +typedef enum + { + FFEINTRIN_familyNONE, /* Not in any family. */ + FFEINTRIN_familyF77, /* ANSI FORTRAN 77. */ + FFEINTRIN_familyGNU, /* GNU Fortran intrinsics. */ + FFEINTRIN_familyF2C, /* f2c intrinsics. */ + FFEINTRIN_familyF90, /* Fortran 90. */ + FFEINTRIN_familyF95 = FFEINTRIN_familyF90, + FFEINTRIN_familyVXT, /* VAX/VMS FORTRAN. */ + FFEINTRIN_familyMIL, /* MIL STD 1753 (MVBITS, etc), in mil, vxt, and f90. */ + FFEINTRIN_familyASC, /* ASCII-related (ACHAR, IACHAR), both f2c and f90. */ + FFEINTRIN_familyFVZ, /* in both f2c and VAX/VMS FORTRAN. */ + FFEINTRIN_familyF2U, /* libf2c/libU77 UNIX system intrinsics. */ + FFEINTRIN_familyBADU77, /* libU77 UNIX system intrinsics with bad form. */ + FFEINTRIN_family, + } ffeintrinFamily; + +typedef enum + { +#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) +#define DEFGEN(CODE,NAME,SPEC1,SPEC2) FFEINTRIN_gen ## CODE, +#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) +#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) +#include "intrin.def" +#undef DEFNAME +#undef DEFGEN +#undef DEFSPEC +#undef DEFIMP + FFEINTRIN_gen + } ffeintrinGen; + +typedef enum + { +#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) +#define DEFGEN(CODE,NAME,SPEC1,SPEC2) +#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) FFEINTRIN_spec ## CODE, +#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) +#include "intrin.def" +#undef DEFNAME +#undef DEFGEN +#undef DEFSPEC +#undef DEFIMP + FFEINTRIN_spec + } ffeintrinSpec; + +typedef enum + { +#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) +#define DEFGEN(CODE,NAME,SPEC1,SPEC2) +#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) +#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \ + FFEINTRIN_imp ## CODE, +#include "intrin.def" +#undef DEFNAME +#undef DEFGEN +#undef DEFSPEC +#undef DEFIMP + FFEINTRIN_imp + } ffeintrinImp; + +#if !FFEINTRIN_DOC + +#include "bld.h" +#include "info.h" + +ffeinfoBasictype ffeintrin_basictype (ffeintrinSpec spec); +ffeintrinFamily ffeintrin_family (ffeintrinSpec spec); +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() +#define ffeintrin_init_3() +#define ffeintrin_init_4() +bool ffeintrin_is_actualarg (ffeintrinSpec spec); +bool ffeintrin_is_intrinsic (char *name, ffelexToken t, bool explicit, + ffeintrinGen *gen, ffeintrinSpec *spec, + ffeintrinImp *imp); +bool ffeintrin_is_standard (ffeintrinGen gen, ffeintrinSpec spec); +ffeinfoKindtype ffeintrin_kindtype (ffeintrinSpec spec); +char *ffeintrin_name_generic (ffeintrinGen gen); +char *ffeintrin_name_implementation (ffeintrinImp imp); +char *ffeintrin_name_specific (ffeintrinSpec spec); +ffeIntrinsicState ffeintrin_state_family (ffeintrinFamily family); +#define ffeintrin_terminate_0() +#define ffeintrin_terminate_1() +#define ffeintrin_terminate_2() +#define ffeintrin_terminate_3() +#define ffeintrin_terminate_4() + +#endif /* !FFEINTRIN_DOC */ + +/* End of #include file. */ + +#endif diff --git a/gcc/f/lab.c b/gcc/f/lab.c new file mode 100644 index 000000000000..772553105cc5 --- /dev/null +++ b/gcc/f/lab.c @@ -0,0 +1,159 @@ +/* lab.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + + Description: + Complex data abstraction for Fortran labels. Maintains a single master + list for all labels; it is expected initialization and termination of + this list will occur on program-unit boundaries. + + Modifications: + 22-Aug-89 JCB 1.1 + Change ffelab_new for new ffewhere interface. +*/ + +/* Include files. */ + +#include "proj.h" +#include "lab.h" +#include "malloc.h" + +/* Externals defined here. */ + +ffelab ffelab_list_; +ffelabNumber ffelab_num_news_; + +/* Simple definitions and enumerations. */ + + +/* Internal typedefs. */ + + +/* Private include files. */ + + +/* Internal structure definitions. */ + + +/* Static objects accessed by functions in this module. */ + + +/* Static functions (internal). */ + + +/* Internal macros. */ + + +/* ffelab_find -- Find the ffelab object having the desired label value + + ffelab l; + ffelabValue v; + l = ffelab_find(v); + + If the desired ffelab object doesn't exist, returns NULL. + + Straightforward search of list of ffelabs. */ + +ffelab +ffelab_find (ffelabValue v) +{ + ffelab l; + + for (l = ffelab_list_; (l != NULL) && (ffelab_value (l) != v); l = l->next) + ; + + return l; +} + +/* ffelab_finish -- Shut down label management + + ffelab_finish(); + + At the end of processing a program unit, call this routine to shut down + label management. + + Kill all the labels on the list. */ + +void +ffelab_finish () +{ + ffelab l; + ffelab pl; + + for (pl = NULL, l = ffelab_list_; l != NULL; pl = l, l = l->next) + if (pl != NULL) + malloc_kill_ks (ffe_pool_any_unit (), pl, sizeof (*pl)); + + if (pl != NULL) + malloc_kill_ks (ffe_pool_any_unit (), pl, sizeof (*pl)); +} + +/* ffelab_init_3 -- Initialize label management system + + ffelab_init_3(); + + Initialize the label management system. Do this before a new program + unit is going to be processed. */ + +void +ffelab_init_3 () +{ + ffelab_list_ = NULL; + ffelab_num_news_ = 0; +} + +/* ffelab_new -- Create an ffelab object. + + ffelab l; + ffelabValue v; + l = ffelab_new(v); + + Create a label having a given value. If the value isn't known, pass + FFELAB_valueNONE, and set it later with ffelab_set_value. + + Allocate, initialize, and stick at top of label list. + + 22-Aug-89 JCB 1.1 + Change for new ffewhere interface. */ + +ffelab +ffelab_new (ffelabValue v) +{ + ffelab l; + + ++ffelab_num_news_; + l = (ffelab) malloc_new_ks (ffe_pool_any_unit (), "FFELAB label", sizeof (*l)); + l->next = ffelab_list_; +#ifdef FFECOM_labelHOOK + l->hook = FFECOM_labelNULL; +#endif + l->value = v; + l->firstref_line = ffewhere_line_unknown (); + l->firstref_col = ffewhere_column_unknown (); + l->doref_line = ffewhere_line_unknown (); + l->doref_col = ffewhere_column_unknown (); + l->definition_line = ffewhere_line_unknown (); + l->definition_col = ffewhere_column_unknown (); + l->type = FFELAB_typeUNKNOWN; + ffelab_list_ = l; + return l; +} diff --git a/gcc/f/lab.h b/gcc/f/lab.h new file mode 100644 index 000000000000..d79e35b85ce1 --- /dev/null +++ b/gcc/f/lab.h @@ -0,0 +1,154 @@ +/* lab.h -- Public #include File (module.h template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + lab.c + + Modifications: + 22-Aug-89 JCB 1.1 + Change for new ffewhere interface. +*/ + +/* Allow multiple inclusion to work. */ + +#ifndef _H_f_lab +#define _H_f_lab + +/* Simple definitions and enumerations. */ + +typedef enum + { + FFELAB_typeUNKNOWN, /* No info yet on label. */ + FFELAB_typeANY, /* Label valid for anything, no msgs. */ + FFELAB_typeUSELESS, /* No valid way to reference this label. */ + FFELAB_typeASSIGNABLE, /* Target of ASSIGN: so FORMAT or BRANCH. */ + FFELAB_typeFORMAT, /* FORMAT label. */ + FFELAB_typeLOOPEND, /* Target of a labeled DO statement. */ + FFELAB_typeNOTLOOP, /* Branch target statement not valid DO + target. */ + FFELAB_typeENDIF, /* END IF label. */ + FFELAB_type + } ffelabType; + +#define FFELAB_valueNONE 0 +#define FFELAB_valueMAX 99999 + +/* Typedefs. */ + +typedef struct _ffelab_ *ffelab; +typedef ffelab ffelabHandle; +typedef unsigned long ffelabNumber; /* Count of new labels. */ +#define ffelabNumber_f "l" +typedef unsigned long ffelabValue; +#define ffelabValue_f "l" + +/* Include files needed by this one. */ + +#include "com.h" +#include "where.h" + +/* Structure definitions. */ + +struct _ffelab_ + { + ffelab next; +#ifdef FFECOM_labelHOOK + ffecomLabel hook; +#endif + ffelabValue value; /* 1 through 99999, or 100000+ for temp + labels. */ + unsigned long blocknum; /* Managed entirely by user of module. */ + ffewhereLine firstref_line; + ffewhereColumn firstref_col; + ffewhereLine doref_line; + ffewhereColumn doref_col; + ffewhereLine definition_line; /* ffewhere_line_unknown() if not + defined. */ + ffewhereColumn definition_col; + ffelabType type; + }; + +/* Global objects accessed by users of this module. */ + +extern ffelab ffelab_list_; +extern ffelabNumber ffelab_num_news_; + +/* Declare functions with prototypes. */ + +ffelab ffelab_find (ffelabValue v); +void ffelab_finish (void); +void ffelab_init_3 (void); +ffelab ffelab_new (ffelabValue v); + +/* Define macros. */ + +#define ffelab_blocknum(l) ((l)->blocknum) +#define ffelab_definition_column(l) ((l)->definition_col) +#define ffelab_definition_filename(l) \ + ffewhere_line_filename((l)->definition_line) +#define ffelab_definition_filelinenum(l) \ + ffewhere_line_filelinenum((l)->definition_line) +#define ffelab_definition_line(l) ((l)->definition_line) +#define ffelab_definition_line_number(l) \ + ffewhere_line_number((l)->definition_line) +#define ffelab_doref_column(l) ((l)->doref_col) +#define ffelab_doref_filename(l) ffewhere_line_filename((l)->doref_line) +#define ffelab_doref_filelinenum(l) ffewhere_line_filelinenum((l)->doref_line) +#define ffelab_doref_line(l) ((l)->doref_line) +#define ffelab_doref_line_number(l) ffewhere_line_number((l)->doref_line) +#define ffelab_firstref_column(l) ((l)->firstref_col) +#define ffelab_firstref_filename(l) ffewhere_line_filename((l)->firstref_line) +#define ffelab_firstref_filelinenum(l) \ + ffewhere_line_filelinenum((l)->firstref_line) +#define ffelab_firstref_line(l) ((l)->firstref_line) +#define ffelab_firstref_line_number(l) ffewhere_line_number((l)->firstref_line) +#define ffelab_handle_done(h) +#define ffelab_handle_first() ((ffelabHandle) ffelab_list_) +#define ffelab_handle_next(h) ((ffelabHandle) (((ffelab) h)->next)) +#define ffelab_handle_target(h) ((ffelab) h) +#define ffelab_hook(l) ((l)->hook) +#define ffelab_init_0() +#define ffelab_init_1() +#define ffelab_init_2() +#define ffelab_init_4() +#define ffelab_kill(l) ffelab_set_value(l,FFELAB_valueNONE); +#define ffelab_new_generated() (ffelab_new(ffelab_generated_++)) +#define ffelab_number() (ffelab_num_news_) +#define ffelab_set_blocknum(l,b) ((l)->blocknum = (b)) +#define ffelab_set_definition_column(l,cn) ((l)->definition_col = (cn)) +#define ffelab_set_definition_line(l,ln) ((l)->definition_line = (ln)) +#define ffelab_set_doref_column(l,cn) ((l)->doref_col = (cn)) +#define ffelab_set_doref_line(l,ln) ((l)->doref_line = (ln)) +#define ffelab_set_firstref_column(l,cn) ((l)->firstref_col = (cn)) +#define ffelab_set_firstref_line(l,ln) ((l)->firstref_line = (ln)) +#define ffelab_set_hook(l,h) ((l)->hook = (h)) +#define ffelab_set_type(l,t) ((l)->type = (t)) +#define ffelab_terminate_0() +#define ffelab_terminate_1() +#define ffelab_terminate_2() +#define ffelab_terminate_3() +#define ffelab_terminate_4() +#define ffelab_type(l) ((l)->type) +#define ffelab_value(l) ((l)->value) + +/* End of #include file. */ + +#endif diff --git a/gcc/f/lang-options.h b/gcc/f/lang-options.h new file mode 100644 index 000000000000..a0e5c80596d9 --- /dev/null +++ b/gcc/f/lang-options.h @@ -0,0 +1,152 @@ +/* lang-options.h file for Fortran + Copyright (C) 1995-1997 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + +*/ + +/* This is the contribution to the `lang_options' array in gcc.c for + g77. */ + +#ifdef __STDC__ /* To be consistent with lang-specs.h. Maybe avoid + overflowing some old compiler's tables, etc. */ + + "-fversion", + "-fnull-version", + "-fset-g77-defaults", +/*"-fident",*/ +/*"-fno-ident",*/ + "-ff66", + "-fno-f66", + "-ff77", + "-fno-f77", + "-ff90", + "-fno-f90", + "-fautomatic", + "-fno-automatic", + "-fdollar-ok", + "-fno-dollar-ok", + "-ff2c", + "-fno-f2c", + "-ff2c-library", + "-fno-f2c-library", + "-ffree-form", + "-fno-free-form", + "-ffixed-form", + "-fno-fixed-form", + "-fpedantic", + "-fno-pedantic", + "-fvxt", + "-fno-vxt", + "-fugly", + "-fno-ugly", + "-fugly-args", + "-fno-ugly-args", + "-fugly-assign", + "-fno-ugly-assign", + "-fugly-assumed", + "-fno-ugly-assumed", + "-fugly-comma", + "-fno-ugly-comma", + "-fugly-complex", + "-fno-ugly-complex", + "-fugly-init", + "-fno-ugly-init", + "-fugly-logint", + "-fno-ugly-logint", + "-fxyzzy", + "-fno-xyzzy", + "-finit-local-zero", + "-fno-init-local-zero", + "-fbackslash", + "-fno-backslash", + "-femulate-complex", + "-fno-emulate-complex", + "-funderscoring", + "-fno-underscoring", + "-fsecond-underscore", + "-fno-second-underscore", + "-fintrin-case-initcap", + "-fintrin-case-upper", + "-fintrin-case-lower", + "-fintrin-case-any", + "-fmatch-case-initcap", + "-fmatch-case-upper", + "-fmatch-case-lower", + "-fmatch-case-any", + "-fsource-case-upper", + "-fsource-case-lower", + "-fsource-case-preserve", + "-fsymbol-case-initcap", + "-fsymbol-case-upper", + "-fsymbol-case-lower", + "-fsymbol-case-any", + "-fcase-strict-upper", + "-fcase-strict-lower", + "-fcase-initcap", + "-fcase-upper", + "-fcase-lower", + "-fcase-preserve", + "-fdcp-intrinsics-delete", + "-fdcp-intrinsics-hide", + "-fdcp-intrinsics-disable", + "-fdcp-intrinsics-enable", + "-ff2c-intrinsics-delete", + "-ff2c-intrinsics-hide", + "-ff2c-intrinsics-disable", + "-ff2c-intrinsics-enable", + "-ff90-intrinsics-delete", + "-ff90-intrinsics-hide", + "-ff90-intrinsics-disable", + "-ff90-intrinsics-enable", + "-fmil-intrinsics-delete", + "-fmil-intrinsics-hide", + "-fmil-intrinsics-disable", + "-fmil-intrinsics-enable", + "-funix-intrinsics-delete", + "-funix-intrinsics-hide", + "-funix-intrinsics-disable", + "-funix-intrinsics-enable", + "-fvxt-intrinsics-delete", + "-fvxt-intrinsics-hide", + "-fvxt-intrinsics-disable", + "-fvxt-intrinsics-enable", + "-fzeros", + "-fno-zeros", + "-fdebug-kludge", + "-fno-debug-kludge", + "-fonetrip", + "-fno-onetrip", + "-fsilent", + "-fno-silent", + "-fglobals", + "-fno-globals", + "-ftypeless-boz", + "-fno-typeless-boz", + "-Wglobals", + "-Wno-globals", +/*"-Wimplicit",*/ +/*"-Wno-implicit",*/ + "-Wsurprising", + "-Wno-surprising", +/*"-Wall",*/ +/* Prefix options. */ + "-I", + "-ffixed-line-length-", +#endif diff --git a/gcc/f/lang-specs.h b/gcc/f/lang-specs.h new file mode 100644 index 000000000000..1e07aaf42f56 --- /dev/null +++ b/gcc/f/lang-specs.h @@ -0,0 +1,96 @@ +/* lang-specs.h file for Fortran + Copyright (C) 1995, 1996 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + +*/ + +/* This is the contribution to the `default_compilers' array in gcc.c for + g77. */ + +#ifdef __STDC__ /* Else stringizing of OO below won't work, but in + K&R case we're not building the f77 language. */ + +#ifdef OBJECT_SUFFIX /* Not defined compiling gcc.c prior to 2.7.0. */ +#define OO "%O" +#else +#define OO ".o" +#endif + + {".F", "@f77-cpp-input"}, + {".fpp", "@f77-cpp-input"}, + {"@f77-cpp-input", + /* For f77 we want -traditional to avoid errors with, for + instance, mismatched '. Also, we avoid unpleasant surprises + with substitution of names not prefixed by `_' by using %P + rather than %p (although this isn't consistent with SGI and + Sun f77, at least) so you test `__unix' rather than `unix'. + -D_LANGUAGE_FORTRAN is used by some compilers like SGI and + might as well be in there. */ + "cpp -lang-c %{nostdinc*} %{C} %{v} %{A*} %{I*} %{P} %I\ + %{C:%{!E:%eGNU C does not support -C without using -E}}\ + %{M} %{MM} %{MD:-MD %b.d} %{MMD:-MMD %b.d} %{MG}\ + -undef -D__GNUC__=%v1 -D__GNUC_MINOR__=%v2\ + %{ansi:-trigraphs -$ -D__STRICT_ANSI__}\ + %{!undef:%P} -D_LANGUAGE_FORTRAN %{trigraphs} \ + %c %{O*:%{!O0:-D__OPTIMIZE__}} -traditional\ + %{g*} %{W*} %{w} %{pedantic*} %{H} %{d*} %C %{D*} %{U*} %{i*} %Z\ + %i %{!M:%{!MM:%{!E:%{!pipe:%g.i}}}}%{E:%W{o*}}%{M:%W{o*}}%{MM:%W{o*}} |\n", + "%{!M:%{!MM:%{!E:f771 %{!pipe:%g.i} -fset-g77-defaults %(f771) \ + %{!Q:-quiet} -dumpbase %b.F %{d*} %{m*} %{a}\ + %{g*} %{O*} %{W*} %{w} %{pedantic*} \ + %{v:-version -fversion} %{pg:-p} %{p} %{f*} %{I*}\ + %{aux-info*}\ + %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ + %{S:%W{o*}%{!o*:-o %b.s}}%{!S:-o %{|!pipe:%g.s}} |\n\ + %{!S:as %a %Y\ + %{c:%W{o*}%{!o*:-o %w%b" OO "}}%{!c:-o %d%w%u" OO "}\ + %{!pipe:%g.s} %A\n }}}}"}, + {".r", "@ratfor"}, + {"@ratfor", + "ratfor %{C} %{v}\ + %{C:%{!E:%eGNU C does not support -C without using -E}}\ + %{!E:%{!pipe:-o %g.f}}%{E:%W{o*}} %i |\n", + "%{!E:f771 %{!pipe:%g.f} -fset-g77-defaults %(f771) \ + %{!Q:-quiet} -dumpbase %b.r %{d*} %{m*} %{a}\ + %{g*} %{O*} %{W*} %{w} %{pedantic*} \ + %{v:-version -fversion} %{pg:-p} %{p} %{f*} %{I*}\ + %{aux-info*}\ + %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ + %{S:%W{o*}%{!o*:-o %b.s}}%{!S:-o %{|!pipe:%g.s}} |\n\ + %{!S:as %a %Y\ + %{c:%W{o*}%{!o*:-o %w%b" OO "}}%{!c:-o %d%w%u" OO "}\ + %{!pipe:%g.s} %A\n }}"}, + {".f", "@f77"}, + {".for", "@f77"}, + {"@f77", + "%{!M:%{!MM:%{!E:f771 %i -fset-g77-defaults %(f771) \ + %{!Q:-quiet} -dumpbase %b.f %{d*} %{m*} %{a}\ + %{g*} %{O*} %{W*} %{w} %{pedantic*}\ + %{v:-version -fversion} %{pg:-p} %{p} %{f*} %{I*}\ + %{aux-info*}\ + %{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\ + %{S:%W{o*}%{!o*:-o %b.s}}%{!S:-o %{|!pipe:%g.s}} |\n\ + %{!S:as %a %Y\ + %{c:%W{o*}%{!o*:-o %w%b" OO "}}%{!c:-o %d%w%u" OO "}\ + %{!pipe:%g.s} %A\n }}}}"}, + +#undef OO + +#endif diff --git a/gcc/f/lex.c b/gcc/f/lex.c new file mode 100644 index 000000000000..acb439157af5 --- /dev/null +++ b/gcc/f/lex.c @@ -0,0 +1,4697 @@ +/* Implementation of Fortran lexer + Copyright (C) 1995-1997 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. */ + +#include "proj.h" +#include +#include "top.h" +#include "bad.h" +#include "com.h" +#include "lex.h" +#include "malloc.h" +#include "src.h" +#if FFECOM_targetCURRENT == FFECOM_targetGCC +#include "config.j" +#include "flags.j" +#include "input.j" +#include "tree.j" +#endif + +#ifdef DWARF_DEBUGGING_INFO +void dwarfout_resume_previous_source_file (register unsigned); +void dwarfout_start_new_source_file (register char *); +void dwarfout_define (register unsigned, register char *); +void dwarfout_undef (register unsigned, register char *); +#endif DWARF_DEBUGGING_INFO + +static void ffelex_append_to_token_ (char c); +static int ffelex_backslash_ (int c, ffewhereColumnNumber col); +static void ffelex_bad_1_ (ffebad errnum, ffewhereLineNumber ln0, + ffewhereColumnNumber cn0); +static void ffelex_bad_2_ (ffebad errnum, ffewhereLineNumber ln0, + ffewhereColumnNumber cn0, ffewhereLineNumber ln1, + ffewhereColumnNumber cn1); +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); +static bool ffelex_is_free_char_ctx_contin_ (ffewhereColumnNumber col); +static bool ffelex_is_free_nonc_ctx_contin_ (ffewhereColumnNumber col); +static void ffelex_next_line_ (void); +static void ffelex_prepare_eos_ (void); +static void ffelex_send_token_ (void); +static ffelexHandler ffelex_swallow_tokens_ (ffelexToken t); +static ffelexToken ffelex_token_new_ (void); + +/* Pertaining to the geometry of the input file. */ + +/* Initial size for card image to be allocated. */ +#define FFELEX_columnINITIAL_SIZE_ 255 + +/* The card image itself, which grows as source lines get longer. It + has room for ffelex_card_size_ + 8 characters, and the length of the + current image is ffelex_card_length_. (The + 8 characters are made + available for easy handling of tabs and such.) */ +static char *ffelex_card_image_; +static ffewhereColumnNumber ffelex_card_size_; +static ffewhereColumnNumber ffelex_card_length_; + +/* Max width for free-form lines (ISO F90). */ +#define FFELEX_FREE_MAX_COLUMNS_ 132 + +/* True if we saw a tab on the current line, as this (currently) means + the line is therefore treated as though final_nontab_column_ were + infinite. */ +static bool ffelex_saw_tab_; + +/* TRUE if current line is known to be erroneous, so don't bother + expanding room for it just to display it. */ +static bool ffelex_bad_line_ = FALSE; + +/* Last column for vanilla, i.e. non-tabbed, line. Usually 72 or 132. */ +static ffewhereColumnNumber ffelex_final_nontab_column_; + +/* Array for quickly deciding what kind of line the current card has, + based on its first character. */ +static ffelexType ffelex_first_char_[256]; + +/* Pertaining to file management. */ + +/* The wf argument of the most recent active ffelex_file_(fixed,free) + function. */ +static ffewhereFile ffelex_current_wf_; + +/* TRUE if an INCLUDE statement can be processed (ffelex_set_include + can be called). */ +static bool ffelex_permit_include_; + +/* TRUE if an INCLUDE statement is pending (ffelex_set_include has been + called). */ +static bool ffelex_set_include_; + +/* Information on the pending INCLUDE file. */ +static FILE *ffelex_include_file_; +static bool ffelex_include_free_form_; +static ffewhereFile ffelex_include_wherefile_; + +/* Current master line count. */ +static ffewhereLineNumber ffelex_linecount_current_; +/* Next master line count. */ +static ffewhereLineNumber ffelex_linecount_next_; + +/* ffewhere info on the latest (currently active) line read from the + active source file. */ +static ffewhereLine ffelex_current_wl_; +static ffewhereColumn ffelex_current_wc_; + +/* Pertaining to tokens in general. */ + +/* Initial capacity for text in a CHARACTER/HOLLERITH/NAME/NAMES/NUMBER + token. */ +#define FFELEX_columnTOKEN_SIZE_ 63 +#if FFELEX_columnTOKEN_SIZE_ < FFEWHERE_indexMAX +#error "token size too small!" +#endif + +/* Current token being lexed. */ +static ffelexToken ffelex_token_; + +/* Handler for current token. */ +static ffelexHandler ffelex_handler_; + +/* TRUE if fixed-form lexer is to generate NAMES instead of NAME tokens. */ +static bool ffelex_names_; + +/* TRUE if both lexers are to generate NAMES instead of NAME tokens. */ +static bool ffelex_names_pure_; + +/* TRUE if 0-9 starts a NAME token instead of NUMBER, for parsing hex + numbers. */ +static bool ffelex_hexnum_; + +/* For ffelex_swallow_tokens(). */ +static ffelexHandler ffelex_eos_handler_; + +/* Number of tokens sent since last EOS or beginning of input file + (include INCLUDEd files). */ +static unsigned long int ffelex_number_of_tokens_; + +/* Number of labels sent (as NUMBER tokens) since last reset of + ffelex_number_of_tokens_ to 0, should be 0 or 1 in most cases. + (Fixed-form source only.) */ +static unsigned long int ffelex_label_tokens_; + +/* Metering for token management, to catch token-memory leaks. */ +static long int ffelex_total_tokens_ = 0; +static long int ffelex_old_total_tokens_ = 1; +static long int ffelex_token_nextid_ = 0; + +/* Pertaining to lexing CHARACTER and HOLLERITH tokens. */ + +/* >0 if a Hollerith constant of that length might be in mid-lex, used + when the next character seen is 'H' or 'h' to enter HOLLERITH lexing + mode (see ffelex_raw_mode_). */ +static long int ffelex_expecting_hollerith_; + +/* -3: Backslash (escape) sequence being lexed in CHARACTER. + -2: Possible closing apostrophe/quote seen in CHARACTER. + -1: Lexing CHARACTER. + 0: Not lexing CHARACTER or HOLLERITH. + >0: Lexing HOLLERITH, value is # chars remaining to expect. */ +static long int ffelex_raw_mode_; + +/* When lexing CHARACTER, open quote/apostrophe (either ' or "). */ +static char ffelex_raw_char_; + +/* TRUE when backslash processing had to use most recent character + to finish its state engine, but that character is not part of + the backslash sequence, so must be reconsidered as a "normal" + character in CHARACTER/HOLLERITH lexing. */ +static bool ffelex_backslash_reconsider_ = FALSE; + +/* Characters preread before lexing happened (might include EOF). */ +static int *ffelex_kludge_chars_ = NULL; + +/* Doing the kludge processing, so not initialized yet. */ +static bool ffelex_kludge_flag_ = FALSE; + +/* The beginning of a (possible) CHARACTER/HOLLERITH token. */ +static ffewhereLine ffelex_raw_where_line_; +static ffewhereColumn ffelex_raw_where_col_; + + +/* Call this to append another character to the current token. If it isn't + currently big enough for it, it will be enlarged. The current token + must be a CHARACTER, HOLLERITH, NAME, NAMES, or NUMBER. */ + +static void +ffelex_append_to_token_ (char c) +{ + if (ffelex_token_->text == NULL) + { + ffelex_token_->text + = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", + FFELEX_columnTOKEN_SIZE_ + 1); + ffelex_token_->size = FFELEX_columnTOKEN_SIZE_; + ffelex_token_->length = 0; + } + else if (ffelex_token_->length >= ffelex_token_->size) + { + ffelex_token_->text + = malloc_resize_ksr (malloc_pool_image (), + ffelex_token_->text, + (ffelex_token_->size << 1) + 1, + ffelex_token_->size + 1); + ffelex_token_->size <<= 1; + assert (ffelex_token_->length < ffelex_token_->size); + } +#ifdef MAP_CHARACTER +Sorry, MAP_CHARACTER is not going to work as expected in GNU Fortran, +please contact fortran@gnu.ai.mit.edu if you wish to fund work to +port g77 to non-ASCII machines. +#endif + ffelex_token_->text[ffelex_token_->length++] = c; +} + +/* Do backslash (escape) processing for a CHARACTER/HOLLERITH token + being lexed. */ + +static int +ffelex_backslash_ (int c, ffewhereColumnNumber col) +{ + static int state = 0; + static unsigned int count; + static int code; + static unsigned int firstdig = 0; + static int nonnull; + static ffewhereLineNumber line; + static ffewhereColumnNumber column; + + /* See gcc/c-lex.c readescape() for a straightforward version + of this state engine for handling backslashes in character/ + hollerith constants. */ + +#define wide_flag 0 +#define warn_traditional 0 +#define flag_traditional 0 + + switch (state) + { + case 0: + if ((c == '\\') + && (ffelex_raw_mode_ != 0) + && ffe_is_backslash ()) + { + state = 1; + column = col + 1; + line = ffelex_linecount_current_; + return EOF; + } + return c; + + case 1: + state = 0; /* Assume simple case. */ + switch (c) + { + case 'x': + if (warn_traditional) + { + ffebad_start_msg_lex ("The meaning of `\\x' (at %0) varies with -traditional", + FFEBAD_severityWARNING); + ffelex_bad_here_ (0, line, column); + ffebad_finish (); + } + + if (flag_traditional) + return c; + + code = 0; + count = 0; + nonnull = 0; + state = 2; + return EOF; + + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': + code = c - '0'; + count = 1; + state = 3; + return EOF; + + case '\\': case '\'': case '"': + return c; + +#if 0 /* Inappropriate for Fortran. */ + case '\n': + ffelex_next_line_ (); + *ignore_ptr = 1; + return 0; +#endif + + case 'n': + return TARGET_NEWLINE; + + case 't': + return TARGET_TAB; + + case 'r': + return TARGET_CR; + + case 'f': + return TARGET_FF; + + case 'b': + return TARGET_BS; + + case 'a': + if (warn_traditional) + { + ffebad_start_msg_lex ("The meaning of `\\a' (at %0) varies with -traditional", + FFEBAD_severityWARNING); + ffelex_bad_here_ (0, line, column); + ffebad_finish (); + } + + if (flag_traditional) + return c; + return TARGET_BELL; + + case 'v': +#if 0 /* Vertical tab is present in common usage compilers. */ + if (flag_traditional) + return c; +#endif + return TARGET_VT; + + case 'e': + case 'E': + case '(': + case '{': + case '[': + case '%': + if (pedantic) + { + char m[2]; + + m[0] = c; + m[1] = '\0'; + ffebad_start_msg_lex ("Non-ANSI-C-standard escape sequence `\\%A' at %0", + FFEBAD_severityPEDANTIC); + ffelex_bad_here_ (0, line, column); + ffebad_string (m); + ffebad_finish (); + } + return (c == 'E' || c == 'e') ? 033 : c; + + case '?': + return c; + + default: + if (c >= 040 && c < 0177) + { + char m[2]; + + m[0] = c; + m[1] = '\0'; + ffebad_start_msg_lex ("Unknown escape sequence `\\%A' at %0", + FFEBAD_severityPEDANTIC); + ffelex_bad_here_ (0, line, column); + ffebad_string (m); + ffebad_finish (); + } + else if (c == EOF) + { + ffebad_start_msg_lex ("Unterminated escape sequence `\\' at %0", + FFEBAD_severityPEDANTIC); + ffelex_bad_here_ (0, line, column); + ffebad_finish (); + } + else + { + char m[20]; + + sprintf (&m[0], "%x", c); + ffebad_start_msg_lex ("Unknown escape sequence `\\' followed by char code 0x%A at %0", + FFEBAD_severityPEDANTIC); + ffelex_bad_here_ (0, line, column); + ffebad_string (m); + ffebad_finish (); + } + } + return c; + + case 2: + if ((c >= 'a' && c <= 'f') + || (c >= 'A' && c <= 'F') + || (c >= '0' && c <= '9')) + { + code *= 16; + if (c >= 'a' && c <= 'f') + code += c - 'a' + 10; + if (c >= 'A' && c <= 'F') + code += c - 'A' + 10; + if (c >= '0' && c <= '9') + code += c - '0'; + if (code != 0 || count != 0) + { + if (count == 0) + firstdig = code; + count++; + } + nonnull = 1; + return EOF; + } + + state = 0; + + if (! nonnull) + { + ffebad_start_msg_lex ("\\x used at %0 with no following hex digits", + FFEBAD_severityFATAL); + ffelex_bad_here_ (0, line, column); + ffebad_finish (); + } + else if (count == 0) + /* Digits are all 0's. Ok. */ + ; + else if ((count - 1) * 4 >= TYPE_PRECISION (integer_type_node) + || (count > 1 + && ((1 << (TYPE_PRECISION (integer_type_node) - (count - 1) * 4)) + <= (int) firstdig))) + { + ffebad_start_msg_lex ("Hex escape at %0 out of range", + FFEBAD_severityPEDANTIC); + ffelex_bad_here_ (0, line, column); + ffebad_finish (); + } + break; + + case 3: + if ((c <= '7') && (c >= '0') && (count++ < 3)) + { + code = (code * 8) + (c - '0'); + return EOF; + } + state = 0; + break; + + default: + assert ("bad backslash state" == NULL); + abort (); + } + + /* Come here when code has a built character, and c is the next + character that might (or might not) be the next one in the constant. */ + + /* Don't bother doing this check for each character going into + CHARACTER or HOLLERITH constants, just the escaped-value ones. + gcc apparently checks every single character, which seems + like it'd be kinda slow and not worth doing anyway. */ + + if (!wide_flag + && TYPE_PRECISION (char_type_node) < HOST_BITS_PER_INT + && code >= (1 << TYPE_PRECISION (char_type_node))) + { + ffebad_start_msg_lex ("Escape sequence at %0 out of range for character", + FFEBAD_severityFATAL); + ffelex_bad_here_ (0, line, column); + ffebad_finish (); + } + + if (c == EOF) + { + /* Known end of constant, just append this character. */ + ffelex_append_to_token_ (code); + if (ffelex_raw_mode_ > 0) + --ffelex_raw_mode_; + return EOF; + } + + /* Have two characters to handle. Do the first, then leave it to the + caller to detect anything special about the second. */ + + ffelex_append_to_token_ (code); + if (ffelex_raw_mode_ > 0) + --ffelex_raw_mode_; + ffelex_backslash_reconsider_ = TRUE; + return c; +} + +/* ffelex_bad_1_ -- Issue diagnostic with one source point + + ffelex_bad_1_(FFEBAD_SOME_ERROR,ffelex_linecount_current_,column + 1); + + Creates ffewhere line and column objects for the source point, sends them + along with the error code to ffebad, then kills the line and column + objects before returning. */ + +static void +ffelex_bad_1_ (ffebad errnum, ffewhereLineNumber ln0, ffewhereColumnNumber cn0) +{ + ffewhereLine wl0; + ffewhereColumn wc0; + + wl0 = ffewhere_line_new (ln0); + wc0 = ffewhere_column_new (cn0); + ffebad_start_lex (errnum); + ffebad_here (0, wl0, wc0); + ffebad_finish (); + ffewhere_line_kill (wl0); + ffewhere_column_kill (wc0); +} + +/* ffelex_bad_2_ -- Issue diagnostic with two source points + + ffelex_bad_2_(FFEBAD_SOME_ERROR,ffelex_linecount_current_,column + 1, + otherline,othercolumn); + + Creates ffewhere line and column objects for the source points, sends them + along with the error code to ffebad, then kills the line and column + objects before returning. */ + +static void +ffelex_bad_2_ (ffebad errnum, ffewhereLineNumber ln0, ffewhereColumnNumber cn0, + ffewhereLineNumber ln1, ffewhereColumnNumber cn1) +{ + ffewhereLine wl0, wl1; + ffewhereColumn wc0, wc1; + + wl0 = ffewhere_line_new (ln0); + wc0 = ffewhere_column_new (cn0); + wl1 = ffewhere_line_new (ln1); + wc1 = ffewhere_column_new (cn1); + ffebad_start_lex (errnum); + ffebad_here (0, wl0, wc0); + ffebad_here (1, wl1, wc1); + ffebad_finish (); + ffewhere_line_kill (wl0); + ffewhere_column_kill (wc0); + ffewhere_line_kill (wl1); + ffewhere_column_kill (wc1); +} + +static void +ffelex_bad_here_ (int n, ffewhereLineNumber ln0, + ffewhereColumnNumber cn0) +{ + ffewhereLine wl0; + ffewhereColumn wc0; + + wl0 = ffewhere_line_new (ln0); + wc0 = ffewhere_column_new (cn0); + ffebad_here (n, wl0, wc0); + ffewhere_line_kill (wl0); + ffewhere_column_kill (wc0); +} + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static int +ffelex_getc_ (FILE *finput) +{ + int c; + + if (ffelex_kludge_chars_ == NULL) + return getc (finput); + + c = *ffelex_kludge_chars_++; + if (c != 0) + return c; + + ffelex_kludge_chars_ = NULL; + return getc (finput); +} + +#endif +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static int +ffelex_cfebackslash_ (int *use_d, int *d, FILE *finput) +{ + register int c = getc (finput); + register int code; + register unsigned count; + unsigned firstdig = 0; + int nonnull; + + *use_d = 0; + + switch (c) + { + case 'x': + if (warn_traditional) + warning ("the meaning of `\\x' varies with -traditional"); + + if (flag_traditional) + return c; + + code = 0; + count = 0; + nonnull = 0; + while (1) + { + c = getc (finput); + if (!(c >= 'a' && c <= 'f') + && !(c >= 'A' && c <= 'F') + && !(c >= '0' && c <= '9')) + { + *use_d = 1; + *d = c; + break; + } + code *= 16; + if (c >= 'a' && c <= 'f') + code += c - 'a' + 10; + if (c >= 'A' && c <= 'F') + code += c - 'A' + 10; + if (c >= '0' && c <= '9') + code += c - '0'; + if (code != 0 || count != 0) + { + if (count == 0) + firstdig = code; + count++; + } + nonnull = 1; + } + if (! nonnull) + error ("\\x used with no following hex digits"); + else if (count == 0) + /* Digits are all 0's. Ok. */ + ; + else if ((count - 1) * 4 >= TYPE_PRECISION (integer_type_node) + || (count > 1 + && (((unsigned) 1 + << (TYPE_PRECISION (integer_type_node) - (count - 1) + * 4)) + <= firstdig))) + pedwarn ("hex escape out of range"); + return code; + + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': + code = 0; + count = 0; + while ((c <= '7') && (c >= '0') && (count++ < 3)) + { + code = (code * 8) + (c - '0'); + c = getc (finput); + } + *use_d = 1; + *d = c; + return code; + + case '\\': case '\'': case '"': + return c; + + case '\n': + ffelex_next_line_ (); + *use_d = 2; + return 0; + + case EOF: + *use_d = 1; + *d = EOF; + return EOF; + + case 'n': + return TARGET_NEWLINE; + + case 't': + return TARGET_TAB; + + case 'r': + return TARGET_CR; + + case 'f': + return TARGET_FF; + + case 'b': + return TARGET_BS; + + case 'a': + if (warn_traditional) + warning ("the meaning of `\\a' varies with -traditional"); + + if (flag_traditional) + return c; + return TARGET_BELL; + + case 'v': +#if 0 /* Vertical tab is present in common usage compilers. */ + if (flag_traditional) + return c; +#endif + return TARGET_VT; + + case 'e': + case 'E': + if (pedantic) + pedwarn ("non-ANSI-standard escape sequence, `\\%c'", c); + return 033; + + case '?': + return c; + + /* `\(', etc, are used at beginning of line to avoid confusing Emacs. */ + case '(': + case '{': + case '[': + /* `\%' is used to prevent SCCS from getting confused. */ + case '%': + if (pedantic) + pedwarn ("non-ANSI escape sequence `\\%c'", c); + return c; + } + if (c >= 040 && c < 0177) + pedwarn ("unknown escape sequence `\\%c'", c); + else + pedwarn ("unknown escape sequence: `\\' followed by char code 0x%x", c); + 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) +{ + ffelexToken token; + char buff[129]; + char *p; + char *q; + char *r; + register unsigned buffer_length; + + if ((*xtoken != NULL) && !ffelex_kludge_flag_) + ffelex_token_kill (*xtoken); + + switch (c) + { + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + buffer_length = ARRAY_SIZE (buff); + p = &buff[0]; + q = p; + r = &buff[buffer_length]; + for (;;) + { + *p++ = c; + if (p >= r) + { + register unsigned bytes_used = (p - q); + + buffer_length *= 2; + q = (char *)xrealloc (q, buffer_length); + p = &q[bytes_used]; + r = &q[buffer_length]; + } + c = ffelex_getc_ (finput); + if (!isdigit (c)) + break; + } + *p = '\0'; + token = ffelex_token_new_number (q, ffewhere_line_unknown (), + ffewhere_column_unknown ()); + + if (q != &buff[0]) + free (q); + + break; + + case '\"': + buffer_length = ARRAY_SIZE (buff); + p = &buff[0]; + q = p; + r = &buff[buffer_length]; + c = ffelex_getc_ (finput); + for (;;) + { + bool done = FALSE; + int use_d = 0; + int d; + + switch (c) + { + case '\"': + c = getc (finput); + done = TRUE; + break; + + case '\\': /* ~~~~~ */ + c = ffelex_cfebackslash_ (&use_d, &d, finput); + break; + + case EOF: + case '\n': + fatal ("Badly formed directive -- no closing quote"); + done = TRUE; + break; + + default: + break; + } + if (done) + break; + + if (use_d != 2) /* 0=>c, 1=>cd, 2=>nil. */ + { + *p++ = c; + if (p >= r) + { + register unsigned bytes_used = (p - q); + + buffer_length = bytes_used * 2; + q = (char *)xrealloc (q, buffer_length); + p = &q[bytes_used]; + r = &q[buffer_length]; + } + } + if (use_d == 1) + c = d; + else + c = getc (finput); + } + *p = '\0'; + token = ffelex_token_new_character (q, ffewhere_line_unknown (), + ffewhere_column_unknown ()); + + if (q != &buff[0]) + free (q); + + break; + + default: + token = NULL; + break; + } + + *xtoken = token; + return c; +} +#endif + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffelex_file_pop_ (char *input_filename) +{ + if (input_file_stack->next) + { + struct file_stack *p = input_file_stack; + input_file_stack = p->next; + free (p); + input_file_stack_tick++; +#ifdef DWARF_DEBUGGING_INFO + if (debug_info_level == DINFO_LEVEL_VERBOSE + && write_symbols == DWARF_DEBUG) + dwarfout_resume_previous_source_file (input_file_stack->line); +#endif /* DWARF_DEBUGGING_INFO */ + } + else + error ("#-lines for entering and leaving files don't match"); + + /* Now that we've pushed or popped the input stack, + update the name in the top element. */ + if (input_file_stack) + input_file_stack->name = input_filename; +} + +#endif +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static void +ffelex_file_push_ (int old_lineno, char *input_filename) +{ + struct file_stack *p + = (struct file_stack *) xmalloc (sizeof (struct file_stack)); + + input_file_stack->line = old_lineno; + p->next = input_file_stack; + p->name = input_filename; + input_file_stack = p; + input_file_stack_tick++; +#ifdef DWARF_DEBUGGING_INFO + if (debug_info_level == DINFO_LEVEL_VERBOSE + && write_symbols == DWARF_DEBUG) + dwarfout_start_new_source_file (input_filename); +#endif /* DWARF_DEBUGGING_INFO */ + + /* Now that we've pushed or popped the input stack, + update the name in the top element. */ + 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 + appropriate current pointer. The caller can then move the current + pointer before actually sending EOS, if desired, as it is in + typical fixed-form cases. */ + +static void +ffelex_prepare_eos_ () +{ + if (ffelex_token_->type != FFELEX_typeNONE) + { + ffelex_backslash_ (EOF, 0); + + switch (ffelex_raw_mode_) + { + case -2: + break; + + case -1: + ffebad_start_lex ((ffelex_raw_char_ == '\'') ? FFEBAD_NO_CLOSING_APOSTROPHE + : FFEBAD_NO_CLOSING_QUOTE); + ffebad_here (0, ffelex_token_->where_line, ffelex_token_->where_col); + ffebad_here (1, ffelex_current_wl_, ffelex_current_wc_); + ffebad_finish (); + break; + + case 0: + break; + + default: + { + char num[20]; + + ffebad_start_lex (FFEBAD_NOT_ENOUGH_HOLLERITH_CHARS); + ffebad_here (0, ffelex_token_->where_line, ffelex_token_->where_col); + ffebad_here (1, ffelex_current_wl_, ffelex_current_wc_); + sprintf (num, "%lu", (unsigned long) ffelex_raw_mode_); + ffebad_string (num); + ffebad_finish (); + /* Make sure the token has some text, might as well fill up with spaces. */ + do + { + ffelex_append_to_token_ (' '); + } while (--ffelex_raw_mode_ > 0); + break; + } + } + ffelex_raw_mode_ = 0; + ffelex_send_token_ (); + } + ffelex_token_->type = FFELEX_typeEOS; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_use (ffelex_current_wc_); +} + +static void +ffelex_finish_statement_ () +{ + if ((ffelex_number_of_tokens_ == 0) + && (ffelex_token_->type == FFELEX_typeNONE)) + return; /* Don't have a statement pending. */ + + if (ffelex_token_->type != FFELEX_typeEOS) + ffelex_prepare_eos_ (); + + ffelex_permit_include_ = TRUE; + ffelex_send_token_ (); + ffelex_permit_include_ = FALSE; + ffelex_number_of_tokens_ = 0; + ffelex_label_tokens_ = 0; + ffelex_names_ = TRUE; + ffelex_names_pure_ = FALSE; /* Probably not necessary. */ + ffelex_hexnum_ = FALSE; + + if (!ffe_is_ffedebug ()) + return; + + /* For debugging purposes only. */ + + if (ffelex_total_tokens_ != ffelex_old_total_tokens_) + { + fprintf (dmpout, "; token_track had %ld tokens, now have %ld.\n", + ffelex_old_total_tokens_, ffelex_total_tokens_); + ffelex_old_total_tokens_ = ffelex_total_tokens_; + } +} + +/* Copied from gcc/c-common.c get_directive_line. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static int +ffelex_get_directive_line_ (char **text, FILE *finput) +{ + static char *directive_buffer = NULL; + static unsigned buffer_length = 0; + register char *p; + register char *buffer_limit; + register int looking_for = 0; + register int char_escaped = 0; + + if (buffer_length == 0) + { + directive_buffer = (char *)xmalloc (128); + buffer_length = 128; + } + + buffer_limit = &directive_buffer[buffer_length]; + + for (p = directive_buffer; ; ) + { + int c; + + /* Make buffer bigger if it is full. */ + if (p >= buffer_limit) + { + register unsigned bytes_used = (p - directive_buffer); + + buffer_length *= 2; + directive_buffer + = (char *)xrealloc (directive_buffer, buffer_length); + p = &directive_buffer[bytes_used]; + buffer_limit = &directive_buffer[buffer_length]; + } + + c = getc (finput); + + /* Discard initial whitespace. */ + if ((c == ' ' || c == '\t') && p == directive_buffer) + continue; + + /* Detect the end of the directive. */ + if ((c == '\n' && looking_for == 0) + || c == EOF) + { + if (looking_for != 0) + fatal ("Bad directive -- missing close-quote"); + + *p++ = '\0'; + *text = directive_buffer; + return c; + } + + *p++ = c; + if (c == '\n') + ffelex_next_line_ (); + + /* Handle string and character constant syntax. */ + if (looking_for) + { + if (looking_for == c && !char_escaped) + looking_for = 0; /* Found terminator... stop looking. */ + } + else + if (c == '\'' || c == '"') + looking_for = c; /* Don't stop buffering until we see another + another one of these (or an EOF). */ + + /* Handle backslash. */ + 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 + of the gcc compiler phase cc1, though interactions between #include + and INCLUDE might possibly produce bizarre results in terms of + error reporting and the generation of debugging info vis-a-vis the + locations of some things. + + Returns the next character unhandled, which is always newline or EOF. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +static int +ffelex_hash_ (FILE *finput) +{ + register int c; + ffelexToken token = NULL; + + /* Read first nonwhite char after the `#'. */ + + c = ffelex_getc_ (finput); + while (c == ' ' || c == '\t') + c = ffelex_getc_ (finput); + + /* If a letter follows, then if the word here is `line', skip + it and ignore it; otherwise, ignore the line, with an error + if the word isn't `pragma', `ident', `define', or `undef'. */ + + if ((c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')) + { + if (c == 'p') + { + if (getc (finput) == 'r' + && getc (finput) == 'a' + && getc (finput) == 'g' + && getc (finput) == 'm' + && getc (finput) == 'a' + && ((c = getc (finput)) == ' ' || c == '\t' || c == '\n' + || c == EOF)) + { + goto skipline; +#if 0 /* g77 doesn't handle pragmas, so ignores them FOR NOW. */ +#ifdef HANDLE_SYSV_PRAGMA + return handle_sysv_pragma (finput, c); +#else /* !HANDLE_SYSV_PRAGMA */ +#ifdef HANDLE_PRAGMA + HANDLE_PRAGMA (finput); +#endif /* HANDLE_PRAGMA */ + goto skipline; +#endif /* !HANDLE_SYSV_PRAGMA */ +#endif /* 0 */ + } + } + + else if (c == 'd') + { + if (getc (finput) == 'e' + && getc (finput) == 'f' + && getc (finput) == 'i' + && getc (finput) == 'n' + && getc (finput) == 'e' + && ((c = getc (finput)) == ' ' || c == '\t' || c == '\n' + || c == EOF)) + { + char *text; + + c = ffelex_get_directive_line_ (&text, finput); + +#ifdef DWARF_DEBUGGING_INFO + if ((debug_info_level == DINFO_LEVEL_VERBOSE) + && (write_symbols == DWARF_DEBUG)) + dwarfout_define (lineno, text); +#endif /* DWARF_DEBUGGING_INFO */ + + goto skipline; + } + } + else if (c == 'u') + { + if (getc (finput) == 'n' + && getc (finput) == 'd' + && getc (finput) == 'e' + && getc (finput) == 'f' + && ((c = getc (finput)) == ' ' || c == '\t' || c == '\n' + || c == EOF)) + { + char *text; + + c = ffelex_get_directive_line_ (&text, finput); + +#ifdef DWARF_DEBUGGING_INFO + if ((debug_info_level == DINFO_LEVEL_VERBOSE) + && (write_symbols == DWARF_DEBUG)) + dwarfout_undef (lineno, text); +#endif /* DWARF_DEBUGGING_INFO */ + + goto skipline; + } + } + else if (c == 'l') + { + if (getc (finput) == 'i' + && getc (finput) == 'n' + && getc (finput) == 'e' + && ((c = getc (finput)) == ' ' || c == '\t')) + goto linenum; + } + else if (c == 'i') + { + if (getc (finput) == 'd' + && getc (finput) == 'e' + && getc (finput) == 'n' + && getc (finput) == 't' + && ((c = getc (finput)) == ' ' || c == '\t')) + { + /* #ident. The pedantic warning is now in cccp.c. */ + + /* Here we have just seen `#ident '. + A string constant should follow. */ + + while (c == ' ' || c == '\t') + c = getc (finput); + + /* If no argument, ignore the line. */ + if (c == '\n' || c == EOF) + return c; + + c = ffelex_cfelex_ (&token, finput, c); + + if ((token == NULL) + || (ffelex_token_type (token) != FFELEX_typeCHARACTER)) + { + error ("invalid #ident"); + goto skipline; + } + + if (ffe_is_ident ()) + { +#ifdef ASM_OUTPUT_IDENT + ASM_OUTPUT_IDENT (asm_out_file, + ffelex_token_text (token)); +#endif + } + + /* Skip the rest of this line. */ + goto skipline; + } + } + + error ("undefined or invalid # directive"); + goto skipline; + } + + linenum: + /* Here we have either `#line' or `# '. + In either case, it should be a line number; a digit should follow. */ + + while (c == ' ' || c == '\t') + c = ffelex_getc_ (finput); + + /* If the # is the only nonwhite char on the line, + just ignore it. Check the new newline. */ + if (c == '\n' || c == EOF) + return c; + + /* Something follows the #; read a token. */ + + c = ffelex_cfelex_ (&token, finput, c); + + if ((token != NULL) + && (ffelex_token_type (token) == FFELEX_typeNUMBER)) + { + int old_lineno = lineno; + char *old_input_filename = input_filename; + ffewhereFile wf; + + /* subtract one, because it is the following line that + gets the specified number */ + int l = atoi (ffelex_token_text (token)) - 1; + + /* Is this the last nonwhite stuff on the line? */ + while (c == ' ' || c == '\t') + c = ffelex_getc_ (finput); + if (c == '\n' || c == EOF) + { + /* No more: store the line number and check following line. */ + lineno = l; + if (!ffelex_kludge_flag_) + { + ffewhere_file_set (NULL, TRUE, (ffewhereLineNumber) l); + + if (token != NULL) + ffelex_token_kill (token); + } + return c; + } + + /* More follows: it must be a string constant (filename). */ + + /* Read the string constant. */ + c = ffelex_cfelex_ (&token, finput, c); + + if ((token == NULL) + || (ffelex_token_type (token) != FFELEX_typeCHARACTER)) + { + error ("invalid #line"); + goto skipline; + } + + lineno = l; + + if (ffelex_kludge_flag_) + input_filename = ffelex_token_text (token); + else + { + wf = ffewhere_file_new (ffelex_token_text (token), + ffelex_token_length (token)); + input_filename = ffewhere_file_name (wf); + ffewhere_file_set (wf, TRUE, (ffewhereLineNumber) l); + } + +#if 0 /* Not sure what g77 should do with this yet. */ + /* Each change of file name + reinitializes whether we are now in a system header. */ + in_system_header = 0; +#endif + + if (main_input_filename == 0) + main_input_filename = input_filename; + + /* Is this the last nonwhite stuff on the line? */ + while (c == ' ' || c == '\t') + c = getc (finput); + if (c == '\n' || c == EOF) + { + if (!ffelex_kludge_flag_) + { + /* Update the name in the top element of input_file_stack. */ + if (input_file_stack) + input_file_stack->name = input_filename; + + if (token != NULL) + ffelex_token_kill (token); + } + return c; + } + + c = ffelex_cfelex_ (&token, finput, c); + + /* `1' after file name means entering new file. + `2' after file name means just left a file. */ + + if ((token != NULL) + && (ffelex_token_type (token) == FFELEX_typeNUMBER)) + { + int num = atoi (ffelex_token_text (token)); + + if (ffelex_kludge_flag_) + { + lineno = 1; + input_filename = old_input_filename; + fatal ("Use `#line ...' instead of `# ...' in first line"); + } + + if (num == 1) + { + /* Pushing to a new file. */ + ffelex_file_push_ (old_lineno, input_filename); + } + else if (num == 2) + { + /* Popping out of a file. */ + ffelex_file_pop_ (input_filename); + } + + /* Is this the last nonwhite stuff on the line? */ + while (c == ' ' || c == '\t') + c = getc (finput); + if (c == '\n' || c == EOF) + { + if (token != NULL) + ffelex_token_kill (token); + return c; + } + + c = ffelex_cfelex_ (&token, finput, c); + } + + /* `3' after file name means this is a system header file. */ + +#if 0 /* Not sure what g77 should do with this yet. */ + if ((token != NULL) + && (ffelex_token_type (token) == FFELEX_typeNUMBER) + && (atoi (ffelex_token_text (token)) == 3)) + in_system_header = 1; +#endif + + while (c == ' ' || c == '\t') + c = getc (finput); + if (((token != NULL) + || (c != '\n' && c != EOF)) + && ffelex_kludge_flag_) + { + lineno = 1; + input_filename = old_input_filename; + fatal ("Use `#line ...' instead of `# ...' in first line"); + } + } + else + error ("invalid #-line"); + + /* skip the rest of this line. */ + skipline: + if ((token != NULL) && !ffelex_kludge_flag_) + ffelex_token_kill (token); + while ((c = getc (finput)) != EOF && c != '\n') + ; + return c; +} +#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */ + +/* "Image" a character onto the card image, return incremented column number. + + Normally invoking this function as in + column = ffelex_image_char_ (c, column); + is the same as doing: + ffelex_card_image_[column++] = c; + + However, tabs and carriage returns are handled specially, to preserve + the visual "image" of the input line (in most editors) in the card + image. + + Carriage returns are ignored, as they are assumed to be followed + by newlines. + + A tab is handled by first doing: + ffelex_card_image_[column++] = ' '; + That is, it translates to at least one space. Then, as many spaces + are imaged as necessary to bring the column number to the next tab + position, where tab positions start in the ninth column and each + eighth column afterwards. ALSO, a static var named ffelex_saw_tab_ + is set to TRUE to notify the lexer that a tab was seen. + + Columns are numbered and tab stops set as illustrated below: + + 012345670123456701234567... + x y z + xx yy zz + ... + xxxxxxx yyyyyyy zzzzzzz + xxxxxxxx yyyyyyyy... */ + +static ffewhereColumnNumber +ffelex_image_char_ (int c, ffewhereColumnNumber column) +{ + ffewhereColumnNumber old_column = column; + + if (column >= ffelex_card_size_) + { + ffewhereColumnNumber newmax = ffelex_card_size_ << 1; + + if (ffelex_bad_line_) + return column; + + if ((newmax >> 1) != ffelex_card_size_) + { /* Overflowed column number. */ + overflow: /* :::::::::::::::::::: */ + + ffelex_bad_line_ = TRUE; + strcpy (&ffelex_card_image_[column - 3], "..."); + ffelex_card_length_ = column; + ffelex_bad_1_ (FFEBAD_LINE_TOO_LONG, + ffelex_linecount_current_, column + 1); + return column; + } + + ffelex_card_image_ + = malloc_resize_ksr (malloc_pool_image (), + ffelex_card_image_, + newmax + 9, + ffelex_card_size_ + 9); + ffelex_card_size_ = newmax; + } + + switch (c) + { + case '\r': + break; + + case '\t': + ffelex_saw_tab_ = TRUE; + ffelex_card_image_[column++] = ' '; + while ((column & 7) != 0) + ffelex_card_image_[column++] = ' '; + break; + + case '\0': + if (!ffelex_bad_line_) + { + ffelex_bad_line_ = TRUE; + strcpy (&ffelex_card_image_[column], "[\\0]"); + ffelex_card_length_ = column + 4; + ffebad_start_msg_lex ("Null character at %0 -- line ignored", + FFEBAD_severityFATAL); + ffelex_bad_here_ (0, ffelex_linecount_current_, column + 1); + ffebad_finish (); + column += 4; + } + break; + + default: + ffelex_card_image_[column++] = c; + break; + } + + if (column < old_column) + { + column = old_column; + goto overflow; /* :::::::::::::::::::: */ + } + + return column; +} + +static void +ffelex_include_ () +{ + ffewhereFile include_wherefile = ffelex_include_wherefile_; + FILE *include_file = ffelex_include_file_; + /* The rest of this is to push, and after the INCLUDE file is processed, + pop, the static lexer state info that pertains to each particular + input file. */ + char *card_image; + ffewhereColumnNumber card_size = ffelex_card_size_; + ffewhereColumnNumber card_length = ffelex_card_length_; + ffewhereLine current_wl = ffelex_current_wl_; + ffewhereColumn current_wc = ffelex_current_wc_; + bool saw_tab = ffelex_saw_tab_; + ffewhereColumnNumber final_nontab_column = ffelex_final_nontab_column_; + ffewhereFile current_wf = ffelex_current_wf_; + ffewhereLineNumber linecount_current = ffelex_linecount_current_; + ffewhereLineNumber linecount_offset + = ffewhere_line_filelinenum (current_wl); +#if FFECOM_targetCURRENT == FFECOM_targetGCC + int old_lineno = lineno; + char *old_input_filename = input_filename; +#endif + + if (card_length != 0) + { + card_image = malloc_new_ks (malloc_pool_image (), + "FFELEX saved card image", + card_length); + memcpy (card_image, ffelex_card_image_, card_length); + } + else + card_image = NULL; + + ffelex_set_include_ = FALSE; + + ffelex_next_line_ (); + + 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); + + ffecom_close_include (include_file); + + if (card_length != 0) + { +#ifdef REDUCE_CARD_SIZE_AFTER_BIGGY /* Define if occasional large lines. */ +#error "need to handle possible reduction of card size here!!" +#endif + assert (ffelex_card_size_ >= card_length); /* It shrunk?? */ + memcpy (ffelex_card_image_, card_image, card_length); + } + 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_saw_tab_ = saw_tab; + ffelex_current_wc_ = current_wc; + ffelex_current_wl_ = current_wl; + ffelex_card_length_ = card_length; + ffelex_card_size_ = card_size; +} + +/* ffelex_is_free_char_ctx_contin_ -- Character Context Continuation? + + ffewhereColumnNumber col; + int c; // Char at col. + if ((c == '&') && ffelex_is_free_char_ctx_contin_(col + 1)) + // We have a continuation indicator. + + If there are spaces starting at ffelex_card_image_[col] up through + the null character, where is 0 or greater, returns TRUE. */ + +static bool +ffelex_is_free_char_ctx_contin_ (ffewhereColumnNumber col) +{ + while (ffelex_card_image_[col] != '\0') + { + if (ffelex_card_image_[col++] != ' ') + return FALSE; + } + return TRUE; +} + +/* ffelex_is_free_nonc_ctx_contin_ -- Noncharacter Context Continuation? + + ffewhereColumnNumber col; + int c; // Char at col. + if ((c == '&') && ffelex_is_free_nonc_ctx_contin_(col + 1)) + // We have a continuation indicator. + + If there are spaces starting at ffelex_card_image_[col] up through + the null character or '!', where is 0 or greater, returns TRUE. */ + +static bool +ffelex_is_free_nonc_ctx_contin_ (ffewhereColumnNumber col) +{ + while ((ffelex_card_image_[col] != '\0') && (ffelex_card_image_[col] != '!')) + { + if (ffelex_card_image_[col++] != ' ') + return FALSE; + } + return TRUE; +} + +static void +ffelex_next_line_ () +{ + ffelex_linecount_current_ = ffelex_linecount_next_; + ++ffelex_linecount_next_; +#if FFECOM_targetCURRENT == FFECOM_targetGCC + ++lineno; +#endif +} + +static void +ffelex_send_token_ () +{ + ++ffelex_number_of_tokens_; + + ffelex_backslash_ (EOF, 0); + + if (ffelex_token_->text == NULL) + { + if (ffelex_token_->type == FFELEX_typeCHARACTER) + { + ffelex_append_to_token_ ('\0'); + ffelex_token_->length = 0; + } + } + else + ffelex_token_->text[ffelex_token_->length] = '\0'; + + assert (ffelex_raw_mode_ == 0); + + if (ffelex_token_->type == FFELEX_typeNAMES) + { + ffewhere_line_kill (ffelex_token_->currentnames_line); + ffewhere_column_kill (ffelex_token_->currentnames_col); + } + + assert (ffelex_handler_ != NULL); + ffelex_handler_ = (ffelexHandler) (*ffelex_handler_) (ffelex_token_); + assert (ffelex_handler_ != NULL); + + ffelex_token_kill (ffelex_token_); + + ffelex_token_ = ffelex_token_new_ (); + ffelex_token_->uses = 1; + ffelex_token_->text = NULL; + if (ffelex_raw_mode_ < 0) + { + ffelex_token_->type = FFELEX_typeCHARACTER; + ffelex_token_->where_line = ffelex_raw_where_line_; + ffelex_token_->where_col = ffelex_raw_where_col_; + ffelex_raw_where_line_ = ffewhere_line_unknown (); + ffelex_raw_where_col_ = ffewhere_column_unknown (); + } + else + { + ffelex_token_->type = FFELEX_typeNONE; + ffelex_token_->where_line = ffewhere_line_unknown (); + ffelex_token_->where_col = ffewhere_column_unknown (); + } + + if (ffelex_set_include_) + ffelex_include_ (); +} + +/* ffelex_swallow_tokens_ -- Eat all tokens delivered to me + + return ffelex_swallow_tokens_; + + Return this handler when you don't want to look at any more tokens in the + statement because you've encountered an unrecoverable error in the + statement. */ + +static ffelexHandler +ffelex_swallow_tokens_ (ffelexToken t) +{ + assert (ffelex_eos_handler_ != NULL); + + if ((ffelex_token_type (t) == FFELEX_typeEOS) + || (ffelex_token_type (t) == FFELEX_typeSEMICOLON)) + return (ffelexHandler) (*ffelex_eos_handler_) (t); + + return (ffelexHandler) ffelex_swallow_tokens_; +} + +static ffelexToken +ffelex_token_new_ () +{ + ffelexToken t; + + ++ffelex_total_tokens_; + + t = (ffelexToken) malloc_new_ks (malloc_pool_image (), + "FFELEX token", sizeof (*t)); + t->id_ = ffelex_token_nextid_++; + return t; +} + +static char * +ffelex_type_string_ (ffelexType type) +{ + static char *types[] = { + "FFELEX_typeNONE", + "FFELEX_typeCOMMENT", + "FFELEX_typeEOS", + "FFELEX_typeEOF", + "FFELEX_typeERROR", + "FFELEX_typeRAW", + "FFELEX_typeQUOTE", + "FFELEX_typeDOLLAR", + "FFELEX_typeHASH", + "FFELEX_typePERCENT", + "FFELEX_typeAMPERSAND", + "FFELEX_typeAPOSTROPHE", + "FFELEX_typeOPEN_PAREN", + "FFELEX_typeCLOSE_PAREN", + "FFELEX_typeASTERISK", + "FFELEX_typePLUS", + "FFELEX_typeMINUS", + "FFELEX_typePERIOD", + "FFELEX_typeSLASH", + "FFELEX_typeNUMBER", + "FFELEX_typeOPEN_ANGLE", + "FFELEX_typeEQUALS", + "FFELEX_typeCLOSE_ANGLE", + "FFELEX_typeNAME", + "FFELEX_typeCOMMA", + "FFELEX_typePOWER", + "FFELEX_typeCONCAT", + "FFELEX_typeDEBUG", + "FFELEX_typeNAMES", + "FFELEX_typeHOLLERITH", + "FFELEX_typeCHARACTER", + "FFELEX_typeCOLON", + "FFELEX_typeSEMICOLON", + "FFELEX_typeUNDERSCORE", + "FFELEX_typeQUESTION", + "FFELEX_typeOPEN_ARRAY", + "FFELEX_typeCLOSE_ARRAY", + "FFELEX_typeCOLONCOLON", + "FFELEX_typeREL_LE", + "FFELEX_typeREL_NE", + "FFELEX_typeREL_EQ", + "FFELEX_typePOINTS", + "FFELEX_typeREL_GE" + }; + + if (type >= ARRAY_SIZE (types)) + return "???"; + return types[type]; +} + +void +ffelex_display_token (ffelexToken t) +{ + if (t == NULL) + t = ffelex_token_; + + fprintf (dmpout, "; Token #%lu is %s (line %" ffewhereLineNumber_f "u, col %" + ffewhereColumnNumber_f "u)", + t->id_, + ffelex_type_string_ (t->type), + ffewhere_line_number (t->where_line), + ffewhere_column_number (t->where_col)); + + if (t->text != NULL) + fprintf (dmpout, ": \"%.*s\"\n", + (int) t->length, + t->text); + else + fprintf (dmpout, ".\n"); +} + +/* ffelex_expecting_character -- Tells if next token expected to be CHARACTER + + if (ffelex_expecting_character()) + // next token delivered by lexer will be CHARACTER. + + If the most recent call to ffelex_set_expecting_hollerith since the last + token was delivered by the lexer passed a length of -1, then we return + TRUE, because the next token we deliver will be typeCHARACTER, else we + return FALSE. */ + +bool +ffelex_expecting_character () +{ + return (ffelex_raw_mode_ != 0); +} + +/* ffelex_file_fixed -- Lex a given file in fixed source form + + ffewhere wf; + FILE *f; + ffelex_file_fixed(wf,f); + + Lexes the file according to Fortran 90 ANSI + VXT specifications. */ + +ffelexHandler +ffelex_file_fixed (ffewhereFile wf, FILE *f) +{ + register int c; /* Character currently under consideration. */ + register ffewhereColumnNumber column; /* Not really; 0 means column 1... */ + bool disallow_continuation_line; + bool ignore_disallowed_continuation; + int latest_char_in_file = 0; /* For getting back into comment-skipping + code. */ + ffelexType lextype; + ffewhereColumnNumber first_label_char; /* First char of label -- + column number. */ + char label_string[6]; /* Text of label. */ + int labi; /* Length of label text. */ + bool finish_statement; /* Previous statement finished? */ + bool have_content; /* This line have content? */ + bool just_do_label; /* Nothing but label (and continuation?) on + line. */ + + /* Lex is called for a particular file, not for a particular program unit. + Yet the two events do share common characteristics. The first line in a + file or in a program unit cannot be a continuation line. No token can + be in mid-formation. No current label for the statement exists, since + there is no current statement. */ + + 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; + ffelex_token_->type = FFELEX_typeNONE; + ffelex_number_of_tokens_ = 0; + ffelex_label_tokens_ = 0; + ffelex_current_wl_ = ffewhere_line_unknown (); + ffelex_current_wc_ = ffewhere_column_unknown (); + latest_char_in_file = '\n'; + goto first_line; /* :::::::::::::::::::: */ + + /* Come here to get a new line. */ + + beginning_of_line: /* :::::::::::::::::::: */ + + disallow_continuation_line = FALSE; + + /* Come here directly when last line didn't clarify the continuation issue. */ + + beginning_of_line_again: /* :::::::::::::::::::: */ + +#ifdef REDUCE_CARD_SIZE_AFTER_BIGGY /* Define if occasional large lines. */ + if (ffelex_card_size_ != FFELEX_columnINITIAL_SIZE_) + { + ffelex_card_image_ + = malloc_resize_ks (malloc_pool_image (), + ffelex_card_image_, + FFELEX_columnINITIAL_SIZE_ + 9, + ffelex_card_size_ + 9); + ffelex_card_size_ = FFELEX_columnINITIAL_SIZE_; + } +#endif + + first_line: /* :::::::::::::::::::: */ + + c = latest_char_in_file; + if ((c == EOF) || ((c = ffelex_getc_ (f)) == EOF)) + { + + end_of_file: /* :::::::::::::::::::: */ + + /* Line ending in EOF instead of \n still counts as a whole line. */ + + ffelex_finish_statement_ (); + ffewhere_line_kill (ffelex_current_wl_); + ffewhere_column_kill (ffelex_current_wc_); + return (ffelexHandler) ffelex_handler_; + } + + ffelex_next_line_ (); + + ffelex_bad_line_ = FALSE; + + /* Skip over comment (and otherwise ignored) lines as quickly as possible! */ + + while (((lextype = ffelex_first_char_[c]) == FFELEX_typeCOMMENT) + || (lextype == FFELEX_typeERROR) + || (lextype == FFELEX_typeSLASH) + || (lextype == FFELEX_typeHASH)) + { + /* Test most frequent type of line first, etc. */ + if ((lextype == FFELEX_typeCOMMENT) + || ((lextype == FFELEX_typeSLASH) + && ((c = getc (f)) == '*'))) /* NOTE SIDE-EFFECT. */ + { + /* Typical case (straight comment), just ignore rest of line. */ + comment_line: /* :::::::::::::::::::: */ + + 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. */ + ffelex_card_image_[0] = '/'; + ffelex_card_image_[1] = c; + column = 2; + goto bad_first_character; /* :::::::::::::::::::: */ + } + else + /* typeERROR or unsupported typeHASH. */ + { /* Bad first character, get line and display + it with message. */ + column = ffelex_image_char_ (c, 0); + + bad_first_character: /* :::::::::::::::::::: */ + + ffelex_bad_line_ = TRUE; + while (((c = getc (f)) != '\n') && (c != EOF)) + column = ffelex_image_char_ (c, column); + ffelex_card_image_[column] = '\0'; + ffelex_card_length_ = column; + ffelex_bad_1_ (FFEBAD_FIRST_CHAR_INVALID, + ffelex_linecount_current_, 1); + } + + /* Read past last char in line. */ + + if (c == EOF) + { + ffelex_next_line_ (); + goto end_of_file; /* :::::::::::::::::::: */ + } + + c = getc (f); + + ffelex_next_line_ (); + + if (c == EOF) + goto end_of_file; /* :::::::::::::::::::: */ + + ffelex_bad_line_ = FALSE; + } /* while [c, first char, means comment] */ + + ffelex_saw_tab_ + = (c == '&') + || (ffelex_final_nontab_column_ == 0); + + if (lextype == FFELEX_typeDEBUG) + c = ' '; /* A 'D' or 'd' in column 1 with the + debug-lines option on. */ + + column = ffelex_image_char_ (c, 0); + + /* Read the entire line in as is (with whitespace processing). */ + + while (((c = getc (f)) != '\n') && (c != EOF)) + column = ffelex_image_char_ (c, column); + + if (ffelex_bad_line_) + { + ffelex_card_image_[column] = '\0'; + ffelex_card_length_ = column; + goto comment_line; /* :::::::::::::::::::: */ + } + + /* If no tab, cut off line after column 72/132. */ + + if (!ffelex_saw_tab_ && (column > ffelex_final_nontab_column_)) + { + /* Technically, we should now fill ffelex_card_image_ up thru column + 72/132 with spaces, since character/hollerith constants must count + them in that manner. To save CPU time in several ways (avoid a loop + here that would be used only when we actually end a line in + character-constant mode; avoid writing memory unnecessarily; avoid a + loop later checking spaces when not scanning for character-constant + characters), we don't do this, and we do the appropriate thing when + we encounter end-of-line while actually processing a character + constant. */ + + column = ffelex_final_nontab_column_; + } + ffelex_card_image_[column] = '\0'; + ffelex_card_length_ = column; + + /* Save next char in file so we can use register-based c while analyzing + line we just read. */ + + latest_char_in_file = c; /* Should be either '\n' or EOF. */ + + have_content = FALSE; + + /* Handle label, if any. */ + + labi = 0; + first_label_char = FFEWHERE_columnUNKNOWN; + for (column = 0; column < 5; ++column) + { + switch (c = ffelex_card_image_[column]) + { + case '\0': + case '!': + goto stop_looking; /* :::::::::::::::::::: */ + + case ' ': + break; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + label_string[labi++] = c; + if (first_label_char == FFEWHERE_columnUNKNOWN) + first_label_char = column + 1; + break; + + case '&': + if (column != 0) + { + ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC, + ffelex_linecount_current_, + column + 1); + goto beginning_of_line_again; /* :::::::::::::::::::: */ + } + if (ffe_is_pedantic ()) + ffelex_bad_1_ (FFEBAD_AMPERSAND, + ffelex_linecount_current_, 1); + finish_statement = FALSE; + just_do_label = FALSE; + goto got_a_continuation; /* :::::::::::::::::::: */ + + case '/': + if (ffelex_card_image_[column + 1] == '*') + goto stop_looking; /* :::::::::::::::::::: */ + /* Fall through. */ + default: + ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC, + ffelex_linecount_current_, column + 1); + goto beginning_of_line_again; /* :::::::::::::::::::: */ + } + } + + stop_looking: /* :::::::::::::::::::: */ + + label_string[labi] = '\0'; + + /* Find first nonblank char starting with continuation column. */ + + if (column == 5) /* In which case we didn't see end of line in + label field. */ + while ((c = ffelex_card_image_[column]) == ' ') + ++column; + + /* Now we're trying to figure out whether this is a continuation line and + whether there's anything else of substance on the line. The cases are + as follows: + + 1. If a line has an explicit continuation character (other than the digit + zero), then if it also has a label, the label is ignored and an error + message is printed. Any remaining text on the line is passed to the + parser tasks, thus even an all-blank line (possibly with an ignored + label) aside from a positive continuation character might have meaning + in the midst of a character or hollerith constant. + + 2. If a line has no explicit continuation character (that is, it has a + space in column 6 and the first non-space character past column 6 is + not a digit 0-9), then there are two possibilities: + + A. A label is present and/or a non-space (and non-comment) character + appears somewhere after column 6. Terminate processing of the previous + statement, if any, send the new label for the next statement, if any, + and start processing a new statement with this non-blank character, if + any. + + B. The line is essentially blank, except for a possible comment character. + Don't terminate processing of the previous statement and don't pass any + characters to the parser tasks, since the line is not flagged as a + continuation line. We treat it just like a completely blank line. + + 3. If a line has a continuation character of zero (0), then we terminate + processing of the previous statement, if any, send the new label for the + next statement, if any, and start processing a new statement, if any + non-blank characters are present. + + If, when checking to see if we should terminate the previous statement, it + is found that there is no previous statement but that there is an + outstanding label, substitute CONTINUE as the statement for the label + and display an error message. */ + + finish_statement = FALSE; + just_do_label = FALSE; + + switch (c) + { + case '!': /* ANSI Fortran 90 says ! in column 6 is + continuation. */ + /* VXT Fortran says ! anywhere is comment, even column 6. */ + if (ffe_is_vxt () || (column != 5)) + goto no_tokens_on_line; /* :::::::::::::::::::: */ + goto got_a_continuation; /* :::::::::::::::::::: */ + + case '/': + if (ffelex_card_image_[column + 1] != '*') + goto some_other_character; /* :::::::::::::::::::: */ + /* Fall through. */ + if (column == 5) + { + /* This seems right to do. But it is close to call, since / * starting + in column 6 will thus be interpreted as a continuation line + beginning with '*'. */ + + goto got_a_continuation;/* :::::::::::::::::::: */ + } + /* Fall through. */ + case '\0': + /* End of line. Therefore may be continued-through line, so handle + pending label as possible to-be-continued and drive end-of-statement + for any previous statement, else treat as blank line. */ + + no_tokens_on_line: /* :::::::::::::::::::: */ + + if (ffe_is_pedantic () && (c == '/')) + ffelex_bad_1_ (FFEBAD_NON_ANSI_COMMENT, + ffelex_linecount_current_, column + 1); + if (first_label_char != FFEWHERE_columnUNKNOWN) + { /* Can't be a continued-through line if it + has a label. */ + finish_statement = TRUE; + have_content = TRUE; + just_do_label = TRUE; + break; + } + goto beginning_of_line_again; /* :::::::::::::::::::: */ + + case '0': + if (ffe_is_pedantic () && (column != 5)) + ffelex_bad_1_ (FFEBAD_NON_ANSI_CONTINUATION_COLUMN, + ffelex_linecount_current_, column + 1); + finish_statement = TRUE; + goto check_for_content; /* :::::::::::::::::::: */ + + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + + /* NOTE: This label can be reached directly from the code + that lexes the label field in columns 1-5. */ + got_a_continuation: /* :::::::::::::::::::: */ + + if (first_label_char != FFEWHERE_columnUNKNOWN) + { + ffelex_bad_2_ (FFEBAD_LABEL_ON_CONTINUATION, + ffelex_linecount_current_, + first_label_char, + ffelex_linecount_current_, + column + 1); + first_label_char = FFEWHERE_columnUNKNOWN; + } + if (disallow_continuation_line) + { + if (!ignore_disallowed_continuation) + ffelex_bad_1_ (FFEBAD_INVALID_CONTINUATION, + ffelex_linecount_current_, column + 1); + goto beginning_of_line_again; /* :::::::::::::::::::: */ + } + if (ffe_is_pedantic () && (column != 5)) + ffelex_bad_1_ (FFEBAD_NON_ANSI_CONTINUATION_COLUMN, + ffelex_linecount_current_, column + 1); + if ((ffelex_raw_mode_ != 0) + && (((c = ffelex_card_image_[column + 1]) != '\0') + || !ffelex_saw_tab_)) + { + ++column; + have_content = TRUE; + break; + } + + check_for_content: /* :::::::::::::::::::: */ + + while ((c = ffelex_card_image_[++column]) == ' ') + ; + if ((c == '\0') + || (c == '!') + || ((c == '/') + && (ffelex_card_image_[column + 1] == '*'))) + { + if (ffe_is_pedantic () && (c == '/')) + ffelex_bad_1_ (FFEBAD_NON_ANSI_COMMENT, + ffelex_linecount_current_, column + 1); + just_do_label = TRUE; + } + else + have_content = TRUE; + break; + + default: + + some_other_character: /* :::::::::::::::::::: */ + + if (column == 5) + goto got_a_continuation;/* :::::::::::::::::::: */ + + /* Here is the very normal case of a regular character starting in + column 7 or beyond with a blank in column 6. */ + + finish_statement = TRUE; + have_content = TRUE; + break; + } + + if (have_content + || (first_label_char != FFEWHERE_columnUNKNOWN)) + { + /* The line has content of some kind, install new end-statement + point for error messages. Note that "content" includes cases + where there's little apparent content but enough to finish + a statement. That's because finishing a statement can trigger + an impending INCLUDE, and that requires accurate line info being + maintained by the lexer. */ + + if (finish_statement) + ffelex_prepare_eos_ (); /* Prepare EOS before we move current pointer. */ + + ffewhere_line_kill (ffelex_current_wl_); + ffewhere_column_kill (ffelex_current_wc_); + ffelex_current_wl_ = ffewhere_line_new (ffelex_linecount_current_); + ffelex_current_wc_ = ffewhere_column_new (ffelex_card_length_ + 1); + } + + /* We delay this for a combination of reasons. Mainly, it can start + INCLUDE processing, and we want to delay that until the lexer's + info on the line is coherent. And we want to delay that until we're + sure there's a reason to make that info coherent, to avoid saving + lots of useless lines. */ + + if (finish_statement) + ffelex_finish_statement_ (); + + /* If label is present, enclose it in a NUMBER token and send it along. */ + + if (first_label_char != FFEWHERE_columnUNKNOWN) + { + assert (ffelex_token_->type == FFELEX_typeNONE); + ffelex_token_->type = FFELEX_typeNUMBER; + ffelex_append_to_token_ ('\0'); /* Make room for label text. */ + strcpy (ffelex_token_->text, label_string); + ffelex_token_->where_line + = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (first_label_char); + ffelex_token_->length = labi; + ffelex_send_token_ (); + ++ffelex_label_tokens_; + } + + if (just_do_label) + goto beginning_of_line; /* :::::::::::::::::::: */ + + /* Here is the main engine for parsing. c holds the character at column. + It is already known that c is not a blank, end of line, or shriek, + unless ffelex_raw_mode_ is not 0 (indicating we are in a + character/hollerith constant). A partially filled token may already + exist in ffelex_token_. One special case: if, when the end of the line + is reached, continuation_line is FALSE and the only token on the line is + END, then it is indeed the last statement. We don't look for + continuation lines during this program unit in that case. This is + according to ANSI. */ + + if (ffelex_raw_mode_ != 0) + { + + parse_raw_character: /* :::::::::::::::::::: */ + + if (c == '\0') + { + ffewhereColumnNumber i; + + if (ffelex_saw_tab_ || (column >= ffelex_final_nontab_column_)) + goto beginning_of_line; /* :::::::::::::::::::: */ + + /* Pad out line with "virtual" spaces. */ + + for (i = column; i < ffelex_final_nontab_column_; ++i) + ffelex_card_image_[i] = ' '; + ffelex_card_image_[i] = '\0'; + ffelex_card_length_ = i; + c = ' '; + } + + switch (ffelex_raw_mode_) + { + case -3: + c = ffelex_backslash_ (c, column); + if (c == EOF) + break; + + if (!ffelex_backslash_reconsider_) + ffelex_append_to_token_ (c); + ffelex_raw_mode_ = -1; + break; + + case -2: + if (c == ffelex_raw_char_) + { + ffelex_raw_mode_ = -1; + ffelex_append_to_token_ (c); + } + else + { + ffelex_raw_mode_ = 0; + ffelex_backslash_reconsider_ = TRUE; + } + break; + + case -1: + if (c == ffelex_raw_char_) + ffelex_raw_mode_ = -2; + else + { + c = ffelex_backslash_ (c, column); + if (c == EOF) + { + ffelex_raw_mode_ = -3; + break; + } + + ffelex_append_to_token_ (c); + } + break; + + default: + c = ffelex_backslash_ (c, column); + if (c == EOF) + break; + + if (!ffelex_backslash_reconsider_) + { + ffelex_append_to_token_ (c); + --ffelex_raw_mode_; + } + break; + } + + if (ffelex_backslash_reconsider_) + ffelex_backslash_reconsider_ = FALSE; + else + c = ffelex_card_image_[++column]; + + if (ffelex_raw_mode_ == 0) + { + ffelex_send_token_ (); + assert (ffelex_raw_mode_ == 0); + while (c == ' ') + c = ffelex_card_image_[++column]; + if ((c == '\0') + || (c == '!') + || ((c == '/') + && (ffelex_card_image_[column + 1] == '*'))) + goto beginning_of_line; /* :::::::::::::::::::: */ + goto parse_nonraw_character; /* :::::::::::::::::::: */ + } + goto parse_raw_character; /* :::::::::::::::::::: */ + } + + parse_nonraw_character: /* :::::::::::::::::::: */ + + switch (ffelex_token_->type) + { + case FFELEX_typeNONE: + switch (c) + { + case '\"': + ffelex_token_->type = FFELEX_typeQUOTE; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '$': + ffelex_token_->type = FFELEX_typeDOLLAR; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '%': + ffelex_token_->type = FFELEX_typePERCENT; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '&': + ffelex_token_->type = FFELEX_typeAMPERSAND; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '\'': + ffelex_token_->type = FFELEX_typeAPOSTROPHE; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '(': + ffelex_token_->type = FFELEX_typeOPEN_PAREN; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case ')': + ffelex_token_->type = FFELEX_typeCLOSE_PAREN; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '*': + ffelex_token_->type = FFELEX_typeASTERISK; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '+': + ffelex_token_->type = FFELEX_typePLUS; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case ',': + ffelex_token_->type = FFELEX_typeCOMMA; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '-': + ffelex_token_->type = FFELEX_typeMINUS; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '.': + ffelex_token_->type = FFELEX_typePERIOD; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '/': + ffelex_token_->type = FFELEX_typeSLASH; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + ffelex_token_->type + = ffelex_hexnum_ ? FFELEX_typeNAME : FFELEX_typeNUMBER; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_append_to_token_ (c); + break; + + case ':': + ffelex_token_->type = FFELEX_typeCOLON; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case ';': + ffelex_token_->type = FFELEX_typeSEMICOLON; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_permit_include_ = TRUE; + ffelex_send_token_ (); + ffelex_permit_include_ = FALSE; + break; + + case '<': + ffelex_token_->type = FFELEX_typeOPEN_ANGLE; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '=': + ffelex_token_->type = FFELEX_typeEQUALS; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '>': + ffelex_token_->type = FFELEX_typeCLOSE_ANGLE; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '?': + ffelex_token_->type = FFELEX_typeQUESTION; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '_': + if (1 || ffe_is_90 ()) + { + ffelex_token_->type = FFELEX_typeUNDERSCORE; + ffelex_token_->where_line + = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col + = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + } + /* Fall through. */ + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + case 'G': + case 'H': + case 'I': + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + case 'S': + case 'T': + case 'U': + case 'V': + case 'W': + case 'X': + case 'Y': + case 'Z': + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'g': + case 'h': + case 'i': + case 'j': + case 'k': + case 'l': + case 'm': + case 'n': + case 'o': + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + case 'z': + c = ffesrc_char_source (c); + + if (ffesrc_char_match_init (c, 'H', 'h') + && ffelex_expecting_hollerith_ != 0) + { + ffelex_raw_mode_ = ffelex_expecting_hollerith_; + ffelex_token_->type = FFELEX_typeHOLLERITH; + ffelex_token_->where_line = ffelex_raw_where_line_; + ffelex_token_->where_col = ffelex_raw_where_col_; + ffelex_raw_where_line_ = ffewhere_line_unknown (); + ffelex_raw_where_col_ = ffewhere_column_unknown (); + c = ffelex_card_image_[++column]; + goto parse_raw_character; /* :::::::::::::::::::: */ + } + + if (ffelex_names_) + { + ffelex_token_->where_line + = ffewhere_line_use (ffelex_token_->currentnames_line + = ffewhere_line_use (ffelex_current_wl_)); + ffelex_token_->where_col + = ffewhere_column_use (ffelex_token_->currentnames_col + = ffewhere_column_new (column + 1)); + ffelex_token_->type = FFELEX_typeNAMES; + } + else + { + ffelex_token_->where_line + = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_token_->type = FFELEX_typeNAME; + } + ffelex_append_to_token_ (c); + break; + + default: + ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER, + ffelex_linecount_current_, column + 1); + ffelex_finish_statement_ (); + disallow_continuation_line = TRUE; + ignore_disallowed_continuation = TRUE; + goto beginning_of_line_again; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeNAME: + switch (c) + { + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + case 'G': + case 'H': + case 'I': + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + case 'S': + case 'T': + case 'U': + case 'V': + case 'W': + case 'X': + case 'Y': + case 'Z': + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'g': + case 'h': + case 'i': + case 'j': + case 'k': + case 'l': + case 'm': + case 'n': + case 'o': + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + case 'z': + c = ffesrc_char_source (c); + /* Fall through. */ + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + case '_': + case '$': + if ((c == '$') + && !ffe_is_dollar_ok ()) + { + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + ffelex_append_to_token_ (c); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeNAMES: + switch (c) + { + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + case 'G': + case 'H': + case 'I': + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + case 'S': + case 'T': + case 'U': + case 'V': + case 'W': + case 'X': + case 'Y': + case 'Z': + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'g': + case 'h': + case 'i': + case 'j': + case 'k': + case 'l': + case 'm': + case 'n': + case 'o': + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + case 'z': + c = ffesrc_char_source (c); + /* Fall through. */ + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + case '_': + case '$': + if ((c == '$') + && !ffe_is_dollar_ok ()) + { + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + if (ffelex_token_->length < FFEWHERE_indexMAX) + { + ffewhere_track (&ffelex_token_->currentnames_line, + &ffelex_token_->currentnames_col, + ffelex_token_->wheretrack, + ffelex_token_->length, + ffelex_linecount_current_, + column + 1); + } + ffelex_append_to_token_ (c); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeNUMBER: + switch (c) + { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + ffelex_append_to_token_ (c); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeASTERISK: + switch (c) + { + case '*': /* ** */ + ffelex_token_->type = FFELEX_typePOWER; + ffelex_send_token_ (); + break; + + default: /* * not followed by another *. */ + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeCOLON: + switch (c) + { + case ':': /* :: */ + ffelex_token_->type = FFELEX_typeCOLONCOLON; + ffelex_send_token_ (); + break; + + default: /* : not followed by another :. */ + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeSLASH: + switch (c) + { + case '/': /* // */ + ffelex_token_->type = FFELEX_typeCONCAT; + ffelex_send_token_ (); + break; + + case ')': /* /) */ + ffelex_token_->type = FFELEX_typeCLOSE_ARRAY; + ffelex_send_token_ (); + break; + + case '=': /* /= */ + ffelex_token_->type = FFELEX_typeREL_NE; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeOPEN_PAREN: + switch (c) + { + case '/': /* (/ */ + ffelex_token_->type = FFELEX_typeOPEN_ARRAY; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeOPEN_ANGLE: + switch (c) + { + case '=': /* <= */ + ffelex_token_->type = FFELEX_typeREL_LE; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeEQUALS: + switch (c) + { + case '=': /* == */ + ffelex_token_->type = FFELEX_typeREL_EQ; + ffelex_send_token_ (); + break; + + case '>': /* => */ + ffelex_token_->type = FFELEX_typePOINTS; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeCLOSE_ANGLE: + switch (c) + { + case '=': /* >= */ + ffelex_token_->type = FFELEX_typeREL_GE; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + default: + assert ("Serious error!!" == NULL); + abort (); + break; + } + + c = ffelex_card_image_[++column]; + + parse_next_character: /* :::::::::::::::::::: */ + + if (ffelex_raw_mode_ != 0) + goto parse_raw_character; /* :::::::::::::::::::: */ + + while (c == ' ') + c = ffelex_card_image_[++column]; + + if ((c == '\0') + || (c == '!') + || ((c == '/') + && (ffelex_card_image_[column + 1] == '*'))) + { + if ((ffelex_number_of_tokens_ == ffelex_label_tokens_) + && (ffelex_token_->type == FFELEX_typeNAMES) + && (ffelex_token_->length == 3) + && (ffesrc_strncmp_2c (ffe_case_match (), + ffelex_token_->text, + "END", "end", "End", + 3) + == 0)) + { + ffelex_finish_statement_ (); + disallow_continuation_line = TRUE; + ignore_disallowed_continuation = FALSE; + goto beginning_of_line_again; /* :::::::::::::::::::: */ + } + goto beginning_of_line; /* :::::::::::::::::::: */ + } + goto parse_nonraw_character; /* :::::::::::::::::::: */ +} + +/* ffelex_file_free -- Lex a given file in free source form + + ffewhere wf; + FILE *f; + ffelex_file_free(wf,f); + + Lexes the file according to Fortran 90 ANSI + VXT specifications. */ + +ffelexHandler +ffelex_file_free (ffewhereFile wf, FILE *f) +{ + register int c; /* Character currently under consideration. */ + register ffewhereColumnNumber column; /* Not really; 0 means column 1... */ + bool continuation_line; + ffewhereColumnNumber continuation_column; + int latest_char_in_file; /* For getting back into comment-skipping + code. */ + + /* Lex is called for a particular file, not for a particular program unit. + Yet the two events do share common characteristics. The first line in a + file or in a program unit cannot be a continuation line. No token can + be in mid-formation. No current label for the statement exists, since + there is no current statement. */ + + 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; + ffelex_number_of_tokens_ = 0; + ffelex_current_wl_ = ffewhere_line_unknown (); + ffelex_current_wc_ = ffewhere_column_unknown (); + latest_char_in_file = '\n'; + + /* Come here to get a new line. */ + + beginning_of_line: /* :::::::::::::::::::: */ + + c = latest_char_in_file; + if ((c == EOF) || ((c = ffelex_getc_ (f)) == EOF)) + { + + end_of_file: /* :::::::::::::::::::: */ + + /* Line ending in EOF instead of \n still counts as a whole line. */ + + ffelex_finish_statement_ (); + ffewhere_line_kill (ffelex_current_wl_); + ffewhere_column_kill (ffelex_current_wc_); + return (ffelexHandler) ffelex_handler_; + } + + ffelex_next_line_ (); + + ffelex_bad_line_ = FALSE; + + /* Skip over initial-comment and empty lines as quickly as possible! */ + + while ((c == '\n') + || (c == '!') + || (c == '#')) + { + if (c == '#') + { +#if FFECOM_targetCURRENT == FFECOM_targetGCC + c = ffelex_hash_ (f); +#else + /* Don't skip over # line after all. */ + break; +#endif + } + + comment_line: /* :::::::::::::::::::: */ + + while ((c != '\n') && (c != EOF)) + c = getc (f); + + if (c == EOF) + { + ffelex_next_line_ (); + goto end_of_file; /* :::::::::::::::::::: */ + } + + c = getc (f); + + ffelex_next_line_ (); + + if (c == EOF) + goto end_of_file; /* :::::::::::::::::::: */ + } + + ffelex_saw_tab_ = FALSE; + + column = ffelex_image_char_ (c, 0); + + /* Read the entire line in as is (with whitespace processing). */ + + while (((c = getc (f)) != '\n') && (c != EOF)) + column = ffelex_image_char_ (c, column); + + if (ffelex_bad_line_) + { + ffelex_card_image_[column] = '\0'; + ffelex_card_length_ = column; + goto comment_line; /* :::::::::::::::::::: */ + } + + /* If no tab, cut off line after column 132. */ + + if (!ffelex_saw_tab_ && (column > FFELEX_FREE_MAX_COLUMNS_)) + column = FFELEX_FREE_MAX_COLUMNS_; + + ffelex_card_image_[column] = '\0'; + ffelex_card_length_ = column; + + /* Save next char in file so we can use register-based c while analyzing + line we just read. */ + + latest_char_in_file = c; /* Should be either '\n' or EOF. */ + + column = 0; + continuation_column = 0; + + /* Skip over initial spaces to see if the first nonblank character + is exclamation point, newline, or EOF (line is therefore a comment) or + ampersand (line is therefore a continuation line). */ + + while ((c = ffelex_card_image_[column]) == ' ') + ++column; + + switch (c) + { + case '!': + case '\0': + goto beginning_of_line; /* :::::::::::::::::::: */ + + case '&': + continuation_column = column + 1; + break; + + default: + break; + } + + /* The line definitely has content of some kind, install new end-statement + point for error messages. */ + + ffewhere_line_kill (ffelex_current_wl_); + ffewhere_column_kill (ffelex_current_wc_); + ffelex_current_wl_ = ffewhere_line_new (ffelex_linecount_current_); + ffelex_current_wc_ = ffewhere_column_new (ffelex_card_length_ + 1); + + /* Figure out which column to start parsing at. */ + + if (continuation_line) + { + if (continuation_column == 0) + { + if (ffelex_raw_mode_ != 0) + { + ffelex_bad_1_ (FFEBAD_BAD_CHAR_CONTINUE, + ffelex_linecount_current_, column + 1); + } + else if (ffelex_token_->type != FFELEX_typeNONE) + { + ffelex_bad_1_ (FFEBAD_BAD_LEXTOK_CONTINUE, + ffelex_linecount_current_, column + 1); + } + } + else if (ffelex_is_free_char_ctx_contin_ (continuation_column)) + { /* Line contains only a single "&" as only + nonblank character. */ + ffelex_bad_1_ (FFEBAD_BAD_FREE_CONTINUE, + ffelex_linecount_current_, continuation_column); + goto beginning_of_line; /* :::::::::::::::::::: */ + } + column = continuation_column; + } + else + column = 0; + + c = ffelex_card_image_[column]; + continuation_line = FALSE; + + /* Here is the main engine for parsing. c holds the character at column. + It is already known that c is not a blank, end of line, or shriek, + unless ffelex_raw_mode_ is not 0 (indicating we are in a + character/hollerith constant). A partially filled token may already + exist in ffelex_token_. */ + + if (ffelex_raw_mode_ != 0) + { + + parse_raw_character: /* :::::::::::::::::::: */ + + switch (c) + { + case '&': + if (ffelex_is_free_char_ctx_contin_ (column + 1)) + { + continuation_line = TRUE; + goto beginning_of_line; /* :::::::::::::::::::: */ + } + break; + + case '\0': + ffelex_finish_statement_ (); + goto beginning_of_line; /* :::::::::::::::::::: */ + + default: + break; + } + + switch (ffelex_raw_mode_) + { + case -3: + c = ffelex_backslash_ (c, column); + if (c == EOF) + break; + + if (!ffelex_backslash_reconsider_) + ffelex_append_to_token_ (c); + ffelex_raw_mode_ = -1; + break; + + case -2: + if (c == ffelex_raw_char_) + { + ffelex_raw_mode_ = -1; + ffelex_append_to_token_ (c); + } + else + { + ffelex_raw_mode_ = 0; + ffelex_backslash_reconsider_ = TRUE; + } + break; + + case -1: + if (c == ffelex_raw_char_) + ffelex_raw_mode_ = -2; + else + { + c = ffelex_backslash_ (c, column); + if (c == EOF) + { + ffelex_raw_mode_ = -3; + break; + } + + ffelex_append_to_token_ (c); + } + break; + + default: + c = ffelex_backslash_ (c, column); + if (c == EOF) + break; + + if (!ffelex_backslash_reconsider_) + { + ffelex_append_to_token_ (c); + --ffelex_raw_mode_; + } + break; + } + + if (ffelex_backslash_reconsider_) + ffelex_backslash_reconsider_ = FALSE; + else + c = ffelex_card_image_[++column]; + + if (ffelex_raw_mode_ == 0) + { + ffelex_send_token_ (); + assert (ffelex_raw_mode_ == 0); + while (c == ' ') + c = ffelex_card_image_[++column]; + if ((c == '\0') || (c == '!')) + { + ffelex_finish_statement_ (); + goto beginning_of_line; /* :::::::::::::::::::: */ + } + if ((c == '&') && ffelex_is_free_nonc_ctx_contin_ (column + 1)) + { + continuation_line = TRUE; + goto beginning_of_line; /* :::::::::::::::::::: */ + } + goto parse_nonraw_character_noncontin; /* :::::::::::::::::::: */ + } + goto parse_raw_character; /* :::::::::::::::::::: */ + } + + parse_nonraw_character: /* :::::::::::::::::::: */ + + if ((c == '&') && ffelex_is_free_nonc_ctx_contin_ (column + 1)) + { + continuation_line = TRUE; + goto beginning_of_line; /* :::::::::::::::::::: */ + } + + parse_nonraw_character_noncontin: /* :::::::::::::::::::: */ + + switch (ffelex_token_->type) + { + case FFELEX_typeNONE: + if (c == ' ') + { /* Otherwise + finish-statement/continue-statement + already checked. */ + while (c == ' ') + c = ffelex_card_image_[++column]; + if ((c == '\0') || (c == '!')) + { + ffelex_finish_statement_ (); + goto beginning_of_line; /* :::::::::::::::::::: */ + } + if ((c == '&') && ffelex_is_free_nonc_ctx_contin_ (column + 1)) + { + continuation_line = TRUE; + goto beginning_of_line; /* :::::::::::::::::::: */ + } + } + + switch (c) + { + case '\"': + ffelex_token_->type = FFELEX_typeQUOTE; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '$': + ffelex_token_->type = FFELEX_typeDOLLAR; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '%': + ffelex_token_->type = FFELEX_typePERCENT; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '&': + ffelex_token_->type = FFELEX_typeAMPERSAND; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '\'': + ffelex_token_->type = FFELEX_typeAPOSTROPHE; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '(': + ffelex_token_->type = FFELEX_typeOPEN_PAREN; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case ')': + ffelex_token_->type = FFELEX_typeCLOSE_PAREN; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '*': + ffelex_token_->type = FFELEX_typeASTERISK; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '+': + ffelex_token_->type = FFELEX_typePLUS; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case ',': + ffelex_token_->type = FFELEX_typeCOMMA; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '-': + ffelex_token_->type = FFELEX_typeMINUS; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '.': + ffelex_token_->type = FFELEX_typePERIOD; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '/': + ffelex_token_->type = FFELEX_typeSLASH; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + ffelex_token_->type + = ffelex_hexnum_ ? FFELEX_typeNAME : FFELEX_typeNUMBER; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_append_to_token_ (c); + break; + + case ':': + ffelex_token_->type = FFELEX_typeCOLON; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case ';': + ffelex_token_->type = FFELEX_typeSEMICOLON; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_permit_include_ = TRUE; + ffelex_send_token_ (); + ffelex_permit_include_ = FALSE; + break; + + case '<': + ffelex_token_->type = FFELEX_typeOPEN_ANGLE; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '=': + ffelex_token_->type = FFELEX_typeEQUALS; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '>': + ffelex_token_->type = FFELEX_typeCLOSE_ANGLE; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + break; + + case '?': + ffelex_token_->type = FFELEX_typeQUESTION; + ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + + case '_': + if (1 || ffe_is_90 ()) + { + ffelex_token_->type = FFELEX_typeUNDERSCORE; + ffelex_token_->where_line + = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col + = ffewhere_column_new (column + 1); + ffelex_send_token_ (); + break; + } + /* Fall through. */ + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + case 'G': + case 'H': + case 'I': + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + case 'S': + case 'T': + case 'U': + case 'V': + case 'W': + case 'X': + case 'Y': + case 'Z': + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'g': + case 'h': + case 'i': + case 'j': + case 'k': + case 'l': + case 'm': + case 'n': + case 'o': + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + case 'z': + c = ffesrc_char_source (c); + + if (ffesrc_char_match_init (c, 'H', 'h') + && ffelex_expecting_hollerith_ != 0) + { + ffelex_raw_mode_ = ffelex_expecting_hollerith_; + ffelex_token_->type = FFELEX_typeHOLLERITH; + ffelex_token_->where_line = ffelex_raw_where_line_; + ffelex_token_->where_col = ffelex_raw_where_col_; + ffelex_raw_where_line_ = ffewhere_line_unknown (); + ffelex_raw_where_col_ = ffewhere_column_unknown (); + c = ffelex_card_image_[++column]; + goto parse_raw_character; /* :::::::::::::::::::: */ + } + + if (ffelex_names_pure_) + { + ffelex_token_->where_line + = ffewhere_line_use (ffelex_token_->currentnames_line + = ffewhere_line_use (ffelex_current_wl_)); + ffelex_token_->where_col + = ffewhere_column_use (ffelex_token_->currentnames_col + = ffewhere_column_new (column + 1)); + ffelex_token_->type = FFELEX_typeNAMES; + } + else + { + ffelex_token_->where_line + = ffewhere_line_use (ffelex_current_wl_); + ffelex_token_->where_col = ffewhere_column_new (column + 1); + ffelex_token_->type = FFELEX_typeNAME; + } + ffelex_append_to_token_ (c); + break; + + default: + ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER, + ffelex_linecount_current_, column + 1); + ffelex_finish_statement_ (); + goto beginning_of_line; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeNAME: + switch (c) + { + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + case 'G': + case 'H': + case 'I': + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + case 'S': + case 'T': + case 'U': + case 'V': + case 'W': + case 'X': + case 'Y': + case 'Z': + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'g': + case 'h': + case 'i': + case 'j': + case 'k': + case 'l': + case 'm': + case 'n': + case 'o': + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + case 'z': + c = ffesrc_char_source (c); + /* Fall through. */ + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + case '_': + case '$': + if ((c == '$') + && !ffe_is_dollar_ok ()) + { + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + ffelex_append_to_token_ (c); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeNAMES: + switch (c) + { + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + case 'G': + case 'H': + case 'I': + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + case 'S': + case 'T': + case 'U': + case 'V': + case 'W': + case 'X': + case 'Y': + case 'Z': + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'g': + case 'h': + case 'i': + case 'j': + case 'k': + case 'l': + case 'm': + case 'n': + case 'o': + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + case 'z': + c = ffesrc_char_source (c); + /* Fall through. */ + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + case '_': + case '$': + if ((c == '$') + && !ffe_is_dollar_ok ()) + { + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + if (ffelex_token_->length < FFEWHERE_indexMAX) + { + ffewhere_track (&ffelex_token_->currentnames_line, + &ffelex_token_->currentnames_col, + ffelex_token_->wheretrack, + ffelex_token_->length, + ffelex_linecount_current_, + column + 1); + } + ffelex_append_to_token_ (c); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeNUMBER: + switch (c) + { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + ffelex_append_to_token_ (c); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeASTERISK: + switch (c) + { + case '*': /* ** */ + ffelex_token_->type = FFELEX_typePOWER; + ffelex_send_token_ (); + break; + + default: /* * not followed by another *. */ + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeCOLON: + switch (c) + { + case ':': /* :: */ + ffelex_token_->type = FFELEX_typeCOLONCOLON; + ffelex_send_token_ (); + break; + + default: /* : not followed by another :. */ + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeSLASH: + switch (c) + { + case '/': /* // */ + ffelex_token_->type = FFELEX_typeCONCAT; + ffelex_send_token_ (); + break; + + case ')': /* /) */ + ffelex_token_->type = FFELEX_typeCLOSE_ARRAY; + ffelex_send_token_ (); + break; + + case '=': /* /= */ + ffelex_token_->type = FFELEX_typeREL_NE; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeOPEN_PAREN: + switch (c) + { + case '/': /* (/ */ + ffelex_token_->type = FFELEX_typeOPEN_ARRAY; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeOPEN_ANGLE: + switch (c) + { + case '=': /* <= */ + ffelex_token_->type = FFELEX_typeREL_LE; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeEQUALS: + switch (c) + { + case '=': /* == */ + ffelex_token_->type = FFELEX_typeREL_EQ; + ffelex_send_token_ (); + break; + + case '>': /* => */ + ffelex_token_->type = FFELEX_typePOINTS; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + case FFELEX_typeCLOSE_ANGLE: + switch (c) + { + case '=': /* >= */ + ffelex_token_->type = FFELEX_typeREL_GE; + ffelex_send_token_ (); + break; + + default: + ffelex_send_token_ (); + goto parse_next_character; /* :::::::::::::::::::: */ + } + break; + + default: + assert ("Serious error!" == NULL); + abort (); + break; + } + + c = ffelex_card_image_[++column]; + + parse_next_character: /* :::::::::::::::::::: */ + + if (ffelex_raw_mode_ != 0) + goto parse_raw_character; /* :::::::::::::::::::: */ + + if ((c == '\0') || (c == '!')) + { + ffelex_finish_statement_ (); + goto beginning_of_line; /* :::::::::::::::::::: */ + } + goto parse_nonraw_character; /* :::::::::::::::::::: */ +} + +/* See the code in com.c that calls this to understand why. */ + +#if FFECOM_targetCURRENT == FFECOM_targetGCC +void +ffelex_hash_kludge (FILE *finput) +{ + /* If you change this constant string, you have to change whatever + code might thus be affected by it in terms of having to use + ffelex_getc_() instead of getc() in the lexers and _hash_. */ + static char match[] = "# 1 \""; + static int kludge[ARRAY_SIZE (match) + 1]; + int c; + char *p; + int *q; + + /* Read chars as long as they match the target string. + Copy them into an array that will serve as a record + of what we read (essentially a multi-char ungetc(), + for code that uses ffelex_getc_ instead of getc() elsewhere + in the lexer. */ + for (p = &match[0], q = &kludge[0], c = getc (finput); + (c == *p) && (*p != '\0') && (c != EOF); + ++p, ++q, c = getc (finput)) + *q = c; + + *q = c; /* Might be EOF, which requires int. */ + *++q = 0; + + ffelex_kludge_chars_ = &kludge[0]; + + if (*p == 0) + { + ffelex_kludge_flag_ = TRUE; + ++ffelex_kludge_chars_; + ffelex_hash_ (finput); /* Handle it NOW rather than later. */ + ffelex_kludge_flag_ = FALSE; + } +} + +#endif +void +ffelex_init_1 () +{ + unsigned int i; + + ffelex_final_nontab_column_ = ffe_fixed_line_length (); + ffelex_card_size_ = FFELEX_columnINITIAL_SIZE_; + ffelex_card_image_ = malloc_new_ksr (malloc_pool_image (), + "FFELEX card image", + FFELEX_columnINITIAL_SIZE_ + 9); + ffelex_card_image_[0] = '\0'; + + for (i = 0; i < 256; ++i) + ffelex_first_char_[i] = FFELEX_typeERROR; + + ffelex_first_char_['\t'] = FFELEX_typeRAW; + ffelex_first_char_['\n'] = FFELEX_typeCOMMENT; + ffelex_first_char_['\v'] = FFELEX_typeCOMMENT; + ffelex_first_char_['\f'] = FFELEX_typeCOMMENT; + ffelex_first_char_['\r'] = FFELEX_typeRAW; + ffelex_first_char_[' '] = FFELEX_typeRAW; + ffelex_first_char_['!'] = FFELEX_typeCOMMENT; + ffelex_first_char_['*'] = FFELEX_typeCOMMENT; + ffelex_first_char_['/'] = FFELEX_typeSLASH; + ffelex_first_char_['&'] = FFELEX_typeRAW; + ffelex_first_char_['#'] = FFELEX_typeHASH; + + for (i = '0'; i <= '9'; ++i) + ffelex_first_char_[i] = FFELEX_typeRAW; + + if ((ffe_case_match () == FFE_caseNONE) + || ((ffe_case_match () == FFE_caseUPPER) + && (ffe_case_source () != FFE_caseLOWER)) /* Idiot! :-) */ + || ((ffe_case_match () == FFE_caseLOWER) + && (ffe_case_source () == FFE_caseLOWER))) + { + ffelex_first_char_['C'] = FFELEX_typeCOMMENT; + ffelex_first_char_['D'] = FFELEX_typeCOMMENT; + } + if ((ffe_case_match () == FFE_caseNONE) + || ((ffe_case_match () == FFE_caseLOWER) + && (ffe_case_source () != FFE_caseUPPER)) /* Idiot! :-) */ + || ((ffe_case_match () == FFE_caseUPPER) + && (ffe_case_source () == FFE_caseUPPER))) + { + ffelex_first_char_['c'] = FFELEX_typeCOMMENT; + ffelex_first_char_['d'] = FFELEX_typeCOMMENT; + } + + ffelex_linecount_current_ = 0; + ffelex_linecount_next_ = 1; + ffelex_raw_mode_ = 0; + ffelex_set_include_ = FALSE; + ffelex_permit_include_ = FALSE; + ffelex_names_ = TRUE; /* First token in program is a names. */ + ffelex_names_pure_ = FALSE; /* Free-form lexer does NAMES only for + FORMAT. */ + ffelex_hexnum_ = FALSE; + ffelex_expecting_hollerith_ = 0; + ffelex_raw_where_line_ = ffewhere_line_unknown (); + ffelex_raw_where_col_ = ffewhere_column_unknown (); + + ffelex_token_ = ffelex_token_new_ (); + ffelex_token_->type = FFELEX_typeNONE; + ffelex_token_->uses = 1; + ffelex_token_->where_line = ffewhere_line_unknown (); + ffelex_token_->where_col = ffewhere_column_unknown (); + ffelex_token_->text = NULL; + + ffelex_handler_ = NULL; +} + +/* ffelex_is_names_expected -- Is the current parser expecting NAMES vs. NAME? + + if (ffelex_is_names_expected()) + // Deliver NAMES token + else + // Deliver NAME token + + Must be called while lexer is active, obviously. */ + +bool +ffelex_is_names_expected () +{ + return ffelex_names_; +} + +/* Current card image, which has the master linecount number + ffelex_linecount_current_. */ + +char * +ffelex_line () +{ + return ffelex_card_image_; +} + +/* ffelex_line_length -- Return length of current lexer line + + printf("Length is %lu\n",ffelex_line_length()); + + Must be called while lexer is active, obviously. */ + +ffewhereColumnNumber +ffelex_line_length () +{ + return ffelex_card_length_; +} + +/* Master line count of current card image, or 0 if no card image + is current. */ + +ffewhereLineNumber +ffelex_line_number () +{ + return ffelex_linecount_current_; +} + +/* ffelex_set_expecting_hollerith -- Set hollerith expectation status + + ffelex_set_expecting_hollerith(0); + + Lex initially assumes no hollerith constant is about to show up. If + syntactic analysis expects one, it should call this function with the + number of characters expected in the constant immediately after recognizing + the decimal number preceding the "H" and the constant itself. Then, if + the next character is indeed H, the lexer will interpret it as beginning + a hollerith constant and ship the token formed by reading the specified + number of characters (interpreting blanks and otherwise-comments too) + from the input file. It is up to syntactic analysis to call this routine + again with 0 to turn hollerith detection off immediately upon receiving + the token that might or might not be HOLLERITH. + + Also call this after seeing an APOSTROPHE or QUOTE token that begins a + character constant. Pass the expected termination character (apostrophe + or quote). + + Pass for length either the length of the hollerith (must be > 0), -1 + meaning expecting a character constant, or 0 to cancel expectation of + a hollerith only after calling it with a length of > 0 and receiving the + next token (which may or may not have been a HOLLERITH token). + + Pass for which either an apostrophe or quote when passing length of -1. + Else which is a don't-care. + + Pass for line and column the line/column info for the token beginning the + character or hollerith constant, for use in error messages, when passing + a length of -1 -- this function will invoke ffewhere_line/column_use to + make its own copies. Else line and column are don't-cares (when length + is 0) and the outstanding copies of the previous line/column info, if + still around, are killed. + + 21-Feb-90 JCB 3.1 + When called with length of 0, also zero ffelex_raw_mode_. This is + so ffest_save_ can undo the effects of replaying tokens like + APOSTROPHE and QUOTE. + 25-Jan-90 JCB 3.0 + New line, column arguments allow error messages to point to the true + beginning of a character/hollerith constant, rather than the beginning + of the content part, which makes them more consistent and helpful. + 05-Nov-89 JCB 2.0 + New "which" argument allows caller to specify termination character, + which should be apostrophe or double-quote, to support Fortran 90. */ + +void +ffelex_set_expecting_hollerith (long length, char which, + ffewhereLine line, ffewhereColumn column) +{ + + /* First kill the pending line/col info, if any (should only be pending + when this call has length==0, the previous call had length>0, and a + non-HOLLERITH token was sent in between the calls, but play it safe). */ + + ffewhere_line_kill (ffelex_raw_where_line_); + ffewhere_column_kill (ffelex_raw_where_col_); + + /* Now handle the length function. */ + switch (length) + { + case 0: + ffelex_expecting_hollerith_ = 0; + ffelex_raw_mode_ = 0; + ffelex_raw_where_line_ = ffewhere_line_unknown (); + ffelex_raw_where_col_ = ffewhere_column_unknown (); + return; /* Don't set new line/column info from args. */ + + case -1: + ffelex_raw_mode_ = -1; + ffelex_raw_char_ = which; + break; + + default: /* length > 0 */ + ffelex_expecting_hollerith_ = length; + break; + } + + /* Now set new line/column information from passed args. */ + + ffelex_raw_where_line_ = ffewhere_line_use (line); + ffelex_raw_where_col_ = ffewhere_column_use (column); +} + +/* ffelex_set_handler -- Set handler for tokens before calling _fixed or _free + + ffelex_set_handler((ffelexHandler) my_first_handler); + + Must be called before calling ffelex_file_fixed or ffelex_file_free or + after they return, but not while they are active. */ + +void +ffelex_set_handler (ffelexHandler first) +{ + ffelex_handler_ = first; +} + +/* ffelex_set_hexnum -- Set hexnum flag + + ffelex_set_hexnum(TRUE); + + Lex normally interprets a token starting with [0-9] as a NUMBER token, + so if it sees a [A-Za-z] in it, it stops parsing the NUMBER and leaves + the character as the first of the next token. But when parsing a + hexadecimal number, by calling this function with TRUE before starting + the parse of the token itself, lex will interpret [0-9] as the start + of a NAME token. */ + +void +ffelex_set_hexnum (bool f) +{ + ffelex_hexnum_ = f; +} + +/* ffelex_set_include -- Set INCLUDE file to be processed next + + ffewhereFile wf; // The ffewhereFile object for the file. + bool free_form; // TRUE means read free-form file, FALSE fixed-form. + FILE *fi; // The file to INCLUDE. + ffelex_set_include(wf,free_form,fi); + + Must be called only after receiving the EOS token following a valid + INCLUDE statement specifying a file that has already been successfully + opened. */ + +void +ffelex_set_include (ffewhereFile wf, bool free_form, FILE *fi) +{ + assert (ffelex_permit_include_); + assert (!ffelex_set_include_); + ffelex_set_include_ = TRUE; + ffelex_include_free_form_ = free_form; + ffelex_include_file_ = fi; + ffelex_include_wherefile_ = wf; +} + +/* ffelex_set_names -- Set names/name flag, names = TRUE + + ffelex_set_names(FALSE); + + Lex initially assumes multiple names should be formed. If this function is + called with FALSE, then single names are formed instead. The differences + are a difference in the token type (FFELEX_typeNAMES vs. FFELEX_typeNAME) + and in whether full source-location tracking is performed (it is for + multiple names, not for single names), which is more expensive in terms of + CPU time. */ + +void +ffelex_set_names (bool f) +{ + ffelex_names_ = f; + if (!f) + ffelex_names_pure_ = FALSE; +} + +/* ffelex_set_names_pure -- Set names/name (pure) flag, names = TRUE + + ffelex_set_names_pure(FALSE); + + Like ffelex_set_names, except affects both lexers. Normally, the + free-form lexer need not generate NAMES tokens because adjacent NAME + tokens must be separated by spaces which causes the lexer to generate + separate tokens for analysis (whereas in fixed-form the spaces are + ignored resulting in one long token). But in FORMAT statements, for + some reason, the Fortran 90 standard specifies that spaces can occur + anywhere within a format-item-list with no effect on the format spec + (except of course within character string edit descriptors), which means + that "1PE14.2" and "1 P E 1 4 . 2" are equivalent. For the FORMAT + statement handling, the existence of spaces makes it hard to deal with, + because each token is seen distinctly (i.e. seven tokens in the latter + example). But when no spaces are provided, as in the former example, + then only four tokens are generated, NUMBER("1"), NAME("PE14"), PERIOD, + NUMBER ("2"). By generating a NAMES instead of NAME, three things happen: + One, ffest_kw_format_ does a substring rather than full-string match, + and thus matches "PE14" to "PE"; two, ffelex_token_xyz_from_names functions + may be used to pull NAME/NAMES and NUMBER tokens out of the NAMES token; + and three, error reporting can point to the actual character rather than + at or prior to it. The first two things could be resolved by providing + alternate functions fairly easy, thus allowing FORMAT handling to expect + both lexers to generate NAME tokens instead of NAMES (with otherwise minor + changes to FORMAT parsing), but the third, error reporting, would suffer, + and when one makes mistakes in a FORMAT, believe me, one wants a pointer + to exactly where the compilers thinks the problem is, to even begin to get + a handle on it. So there. */ + +void +ffelex_set_names_pure (bool f) +{ + ffelex_names_pure_ = f; + ffelex_names_ = f; +} + +/* ffelex_splice_tokens -- Splice off and send tokens from a NAMES + + return (ffelexHandler) ffelex_splice_tokens(first_handler,master_token, + start_char_index); + + Returns first_handler if start_char_index chars into master_token (which + must be a NAMES token) is '\0'. Else, creates a subtoken from that + char, either NUMBER (if it is a digit), a NAME (if a valid firstnamechar), + an UNDERSCORE (if an underscore), or DOLLAR (if a dollar sign) + and sends it to first_handler. If anything other than NAME is sent, the + character at the end of it in the master token is examined to see if it + begins a NAME, NUMBER, UNDERSCORE, or DOLLAR, and, if so, + the handler returned by first_handler is invoked with that token, and + this process is repeated until the end of the master token or a NAME + token is reached. */ + +ffelexHandler +ffelex_splice_tokens (ffelexHandler first, ffelexToken master, + ffeTokenLength start) +{ + char *p; + ffeTokenLength i; + ffelexToken t; + + p = ffelex_token_text (master) + (i = start); + + while (*p != '\0') + { + if (isdigit (*p)) + { + t = ffelex_token_number_from_names (master, i); + p += ffelex_token_length (t); + i += ffelex_token_length (t); + } + else if (ffesrc_is_name_init (*p)) + { + t = ffelex_token_name_from_names (master, i, 0); + p += ffelex_token_length (t); + i += ffelex_token_length (t); + } + else if (*p == '$') + { + t = ffelex_token_dollar_from_names (master, i); + ++p; + ++i; + } + else if (*p == '_') + { + t = ffelex_token_uscore_from_names (master, i); + ++p; + ++i; + } + else + { + assert ("not a valid NAMES character" == NULL); + t = NULL; + } + assert (first != NULL); + first = (ffelexHandler) (*first) (t); + ffelex_token_kill (t); + } + + return first; +} + +/* ffelex_swallow_tokens -- Eat all tokens delivered to me + + return ffelex_swallow_tokens; + + Return this handler when you don't want to look at any more tokens in the + statement because you've encountered an unrecoverable error in the + statement. */ + +ffelexHandler +ffelex_swallow_tokens (ffelexToken t, ffelexHandler handler) +{ + assert (handler != NULL); + + if ((t != NULL) && ((ffelex_token_type (t) == FFELEX_typeEOS) + || (ffelex_token_type (t) == FFELEX_typeSEMICOLON))) + return (ffelexHandler) (*handler) (t); + + ffelex_eos_handler_ = handler; + return (ffelexHandler) ffelex_swallow_tokens_; +} + +/* ffelex_token_dollar_from_names -- Return a dollar from within a names token + + ffelexToken t; + t = ffelex_token_dollar_from_names(t,6); + + It's as if you made a new token of dollar type having the dollar + at, in the example above, the sixth character of the NAMES token. */ + +ffelexToken +ffelex_token_dollar_from_names (ffelexToken t, ffeTokenLength start) +{ + ffelexToken nt; + + assert (t != NULL); + assert (ffelex_token_type (t) == FFELEX_typeNAMES); + assert (start < t->length); + assert (t->text[start] == '$'); + + /* Now make the token. */ + + nt = ffelex_token_new_ (); + nt->type = FFELEX_typeDOLLAR; + nt->length = 0; + nt->uses = 1; + ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line, + t->where_col, t->wheretrack, start); + nt->text = NULL; + return nt; +} + +/* ffelex_token_kill -- Decrement use count for token, kill if no uses left + + ffelexToken t; + ffelex_token_kill(t); + + Complements a call to ffelex_token_use or ffelex_token_new_.... */ + +void +ffelex_token_kill (ffelexToken t) +{ + assert (t != NULL); + + assert (t->uses > 0); + + if (--t->uses != 0) + return; + + --ffelex_total_tokens_; + + if (t->type == FFELEX_typeNAMES) + ffewhere_track_kill (t->where_line, t->where_col, + t->wheretrack, t->length); + ffewhere_line_kill (t->where_line); + ffewhere_column_kill (t->where_col); + if (t->text != NULL) + malloc_kill_ksr (malloc_pool_image (), t->text, t->size + 1); + malloc_kill_ks (malloc_pool_image (), t, sizeof (*t)); +} + +/* Make a new NAME token that is a substring of a NAMES token. */ + +ffelexToken +ffelex_token_name_from_names (ffelexToken t, ffeTokenLength start, + ffeTokenLength len) +{ + ffelexToken nt; + + assert (t != NULL); + assert (ffelex_token_type (t) == FFELEX_typeNAMES); + assert (start < t->length); + if (len == 0) + len = t->length - start; + else + { + assert (len > 0); + assert ((start + len) <= t->length); + } + assert (ffelex_is_firstnamechar (t->text[start])); + + nt = ffelex_token_new_ (); + nt->type = FFELEX_typeNAME; + nt->size = len; /* Assume nobody's gonna fiddle with token + text. */ + nt->length = len; + nt->uses = 1; + ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line, + t->where_col, t->wheretrack, start); + nt->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", + len + 1); + strncpy (nt->text, t->text + start, len); + nt->text[len] = '\0'; + return nt; +} + +/* Make a new NAMES token that is a substring of another NAMES token. */ + +ffelexToken +ffelex_token_names_from_names (ffelexToken t, ffeTokenLength start, + ffeTokenLength len) +{ + ffelexToken nt; + + assert (t != NULL); + assert (ffelex_token_type (t) == FFELEX_typeNAMES); + assert (start < t->length); + if (len == 0) + len = t->length - start; + else + { + assert (len > 0); + assert ((start + len) <= t->length); + } + assert (ffelex_is_firstnamechar (t->text[start])); + + nt = ffelex_token_new_ (); + nt->type = FFELEX_typeNAMES; + nt->size = len; /* Assume nobody's gonna fiddle with token + text. */ + nt->length = len; + nt->uses = 1; + ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line, + t->where_col, t->wheretrack, start); + ffewhere_track_copy (nt->wheretrack, t->wheretrack, start, len); + nt->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", + len + 1); + strncpy (nt->text, t->text + start, len); + nt->text[len] = '\0'; + return nt; +} + +/* Make a new CHARACTER token. */ + +ffelexToken +ffelex_token_new_character (char *s, ffewhereLine l, ffewhereColumn c) +{ + ffelexToken t; + + t = ffelex_token_new_ (); + t->type = FFELEX_typeCHARACTER; + t->length = t->size = strlen (s); /* Assume it won't get bigger. */ + t->uses = 1; + t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", + t->size + 1); + strcpy (t->text, s); + t->where_line = ffewhere_line_use (l); + t->where_col = ffewhere_column_new (c); + return t; +} + +/* Make a new EOF token right after end of file. */ + +ffelexToken +ffelex_token_new_eof () +{ + ffelexToken t; + + t = ffelex_token_new_ (); + t->type = FFELEX_typeEOF; + t->uses = 1; + t->text = NULL; + t->where_line = ffewhere_line_new (ffelex_linecount_current_); + t->where_col = ffewhere_column_new (1); + return t; +} + +/* Make a new NAME token. */ + +ffelexToken +ffelex_token_new_name (char *s, ffewhereLine l, ffewhereColumn c) +{ + ffelexToken t; + + assert (ffelex_is_firstnamechar (*s)); + + t = ffelex_token_new_ (); + t->type = FFELEX_typeNAME; + t->length = t->size = strlen (s); /* Assume it won't get bigger. */ + t->uses = 1; + t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", + t->size + 1); + strcpy (t->text, s); + t->where_line = ffewhere_line_use (l); + t->where_col = ffewhere_column_new (c); + return t; +} + +/* Make a new NAMES token. */ + +ffelexToken +ffelex_token_new_names (char *s, ffewhereLine l, ffewhereColumn c) +{ + ffelexToken t; + + assert (ffelex_is_firstnamechar (*s)); + + t = ffelex_token_new_ (); + t->type = FFELEX_typeNAMES; + t->length = t->size = strlen (s); /* Assume it won't get bigger. */ + t->uses = 1; + t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", + t->size + 1); + strcpy (t->text, s); + t->where_line = ffewhere_line_use (l); + t->where_col = ffewhere_column_new (c); + ffewhere_track_clear (t->wheretrack, t->length); /* Assume contiguous + names. */ + return t; +} + +/* Make a new NUMBER token. + + The first character of the string must be a digit, and only the digits + are copied into the new number. So this may be used to easily extract + a NUMBER token from within any text string. Then the length of the + resulting token may be used to calculate where the digits stopped + in the original string. */ + +ffelexToken +ffelex_token_new_number (char *s, ffewhereLine l, ffewhereColumn c) +{ + ffelexToken t; + ffeTokenLength len; + + /* How long is the string of decimal digits at s? */ + + len = strspn (s, "0123456789"); + + /* Make sure there is at least one digit. */ + + assert (len != 0); + + /* Now make the token. */ + + t = ffelex_token_new_ (); + t->type = FFELEX_typeNUMBER; + t->length = t->size = len; /* Assume it won't get bigger. */ + t->uses = 1; + t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", + len + 1); + strncpy (t->text, s, len); + t->text[len] = '\0'; + t->where_line = ffewhere_line_use (l); + t->where_col = ffewhere_column_new (c); + return t; +} + +/* Make a new token of any type that doesn't contain text. A private + function that is used by public macros in the interface file. */ + +ffelexToken +ffelex_token_new_simple_ (ffelexType type, ffewhereLine l, ffewhereColumn c) +{ + ffelexToken t; + + t = ffelex_token_new_ (); + t->type = type; + t->uses = 1; + t->text = NULL; + t->where_line = ffewhere_line_use (l); + t->where_col = ffewhere_column_new (c); + return t; +} + +/* Make a new NUMBER token from an existing NAMES token. + + Like ffelex_token_new_number, this function calculates the length + of the digit string itself. */ + +ffelexToken +ffelex_token_number_from_names (ffelexToken t, ffeTokenLength start) +{ + ffelexToken nt; + ffeTokenLength len; + + assert (t != NULL); + assert (ffelex_token_type (t) == FFELEX_typeNAMES); + assert (start < t->length); + + /* How long is the string of decimal digits at s? */ + + len = strspn (t->text + start, "0123456789"); + + /* Make sure there is at least one digit. */ + + assert (len != 0); + + /* Now make the token. */ + + nt = ffelex_token_new_ (); + nt->type = FFELEX_typeNUMBER; + nt->size = len; /* Assume nobody's gonna fiddle with token + text. */ + nt->length = len; + nt->uses = 1; + ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line, + t->where_col, t->wheretrack, start); + nt->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text", + len + 1); + strncpy (nt->text, t->text + start, len); + nt->text[len] = '\0'; + return nt; +} + +/* Make a new UNDERSCORE token from a NAMES token. */ + +ffelexToken +ffelex_token_uscore_from_names (ffelexToken t, ffeTokenLength start) +{ + ffelexToken nt; + + assert (t != NULL); + assert (ffelex_token_type (t) == FFELEX_typeNAMES); + assert (start < t->length); + assert (t->text[start] == '_'); + + /* Now make the token. */ + + nt = ffelex_token_new_ (); + nt->type = FFELEX_typeUNDERSCORE; + nt->uses = 1; + ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line, + t->where_col, t->wheretrack, start); + nt->text = NULL; + return nt; +} + +/* ffelex_token_use -- Return another instance of a token + + ffelexToken t; + t = ffelex_token_use(t); + + In a sense, the new token is a copy of the old, though it might be the + same with just a new use count. + + We use the use count method (easy). */ + +ffelexToken +ffelex_token_use (ffelexToken t) +{ + if (t == NULL) + assert ("_token_use: null token" == NULL); + t->uses++; + return t; +} diff --git a/gcc/f/lex.h b/gcc/f/lex.h new file mode 100644 index 000000000000..bae1147dcc53 --- /dev/null +++ b/gcc/f/lex.h @@ -0,0 +1,202 @@ +/* lex.h -- Public #include File (module.h template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + lex.c + + Modifications: + 22-Aug-89 JCB 1.1 + Change for new ffewhere interface. +*/ + +/* Allow multiple inclusion to work. */ + +#ifndef _H_f_lex +#define _H_f_lex + +/* Simple definitions and enumerations. */ + +typedef enum + { + FFELEX_typeNONE, + FFELEX_typeCOMMENT, + FFELEX_typeEOS, + FFELEX_typeEOF, + FFELEX_typeERROR, + FFELEX_typeRAW, + FFELEX_typeQUOTE, + FFELEX_typeDOLLAR, + FFELEX_typeHASH, + FFELEX_typePERCENT, + FFELEX_typeAMPERSAND, + FFELEX_typeAPOSTROPHE, + FFELEX_typeOPEN_PAREN, + FFELEX_typeCLOSE_PAREN, + FFELEX_typeASTERISK, + FFELEX_typePLUS, + FFELEX_typeMINUS, + FFELEX_typePERIOD, + FFELEX_typeSLASH, + FFELEX_typeNUMBER, /* Grep: [0-9][0-9]*. */ + FFELEX_typeOPEN_ANGLE, + FFELEX_typeEQUALS, + FFELEX_typeCLOSE_ANGLE, + FFELEX_typeNAME, /* Grep: [A-Za-z][A-Za-z0-9_]*. */ + FFELEX_typeCOMMA, + FFELEX_typePOWER, /* "**". */ + FFELEX_typeCONCAT, /* "//". */ + FFELEX_typeDEBUG, + FFELEX_typeNAMES, /* Same as FFELEX_typeNAME in initial + context. */ + FFELEX_typeHOLLERITH, /* part of H. */ + FFELEX_typeCHARACTER, /* part of '' or "". */ + FFELEX_typeCOLON, + FFELEX_typeSEMICOLON, + FFELEX_typeUNDERSCORE, + FFELEX_typeQUESTION, + FFELEX_typeOPEN_ARRAY, /* "(/". */ + FFELEX_typeCLOSE_ARRAY, /* "/)". */ + FFELEX_typeCOLONCOLON, /* "::". */ + FFELEX_typeREL_LE, /* "<=". */ + FFELEX_typeREL_NE, /* "<>". */ + FFELEX_typeREL_EQ, /* "==". */ + FFELEX_typePOINTS, /* "=>". */ + FFELEX_typeREL_GE, /* ">=". */ + FFELEX_type + } ffelexType; + +/* Typedefs. */ + +typedef struct _lextoken_ *ffelexToken; +typedef void *lex_sigh_; +typedef lex_sigh_ (*lex_sigh__) (ffelexToken); +typedef lex_sigh__ (*ffelexHandler) (ffelexToken); + +/* Include files needed by this one. */ + +#include +#include "top.h" +#include "where.h" + +/* Structure definitions. */ + +struct _lextoken_ + { + long int id_; /* DEBUG ONLY. */ + ffeTokenLength size; + ffeTokenLength length; + unsigned short uses; + char *text; + ffelexType type; + ffewhereLine where_line; + ffewhereColumn where_col; + ffewhereLine currentnames_line; /* For tracking NAMES tokens. */ + ffewhereColumn currentnames_col; /* For tracking NAMES tokens. */ + ffewhereTrack wheretrack; /* For tracking NAMES tokens. */ + }; + +/* Global objects accessed by users of this module. */ + + +/* Declare functions with prototypes. */ + +void ffelex_display_token (ffelexToken t); +bool ffelex_expecting_character (void); +ffelexHandler ffelex_file_fixed (ffewhereFile wf, FILE *f); +ffelexHandler ffelex_file_free (ffewhereFile wf, FILE *f); +void ffelex_hash_kludge (FILE *f); +void ffelex_init_1 (void); +bool ffelex_is_names_expected (void); +char *ffelex_line (void); +ffewhereColumnNumber ffelex_line_length (void); +ffewhereLineNumber ffelex_line_number (void); +void ffelex_set_expecting_hollerith (long length, char which, + ffewhereLine line, + ffewhereColumn column); +void ffelex_set_handler (ffelexHandler first); +void ffelex_set_hexnum (bool on); +void ffelex_set_include (ffewhereFile wf, bool free_form, FILE *fi); +void ffelex_set_names (bool on); +void ffelex_set_names_pure (bool on); +ffelexHandler ffelex_splice_tokens (ffelexHandler first, ffelexToken master, + ffeTokenLength start); +ffelexHandler ffelex_swallow_tokens (ffelexToken t, ffelexHandler handler); +ffelexToken ffelex_token_dollar_from_names (ffelexToken t, + ffeTokenLength start); +void ffelex_token_kill (ffelexToken t); +ffelexToken ffelex_token_name_from_names (ffelexToken t, + ffeTokenLength start, + ffeTokenLength len); +ffelexToken ffelex_token_names_from_names (ffelexToken t, + ffeTokenLength start, + ffeTokenLength len); +ffelexToken ffelex_token_new (void); +ffelexToken ffelex_token_new_character (char *s, ffewhereLine l, + ffewhereColumn c); +ffelexToken ffelex_token_new_eof (void); +ffelexToken ffelex_token_new_name (char *s, ffewhereLine l, + ffewhereColumn c); +ffelexToken ffelex_token_new_names (char *s, ffewhereLine l, + ffewhereColumn c); +ffelexToken ffelex_token_new_number (char *s, ffewhereLine l, + ffewhereColumn c); +ffelexToken ffelex_token_new_simple_ (ffelexType type, ffewhereLine l, + ffewhereColumn c); +ffelexToken ffelex_token_number_from_names (ffelexToken t, + ffeTokenLength start); +ffelexToken ffelex_token_uscore_from_names (ffelexToken t, + ffeTokenLength start); +ffelexToken ffelex_token_use (ffelexToken t); + +/* Define macros. */ + +#define ffelex_init_0() +#define ffelex_init_2() +#define ffelex_init_3() +#define ffelex_init_4() +#define ffelex_is_firstnamechar(c) \ + (isalpha ((c)) || ((c) == '_')) +#define ffelex_terminate_0() +#define ffelex_terminate_1() +#define ffelex_terminate_2() +#define ffelex_terminate_3() +#define ffelex_terminate_4() +#define ffelex_token_length(t) ((t)->length) +#define ffelex_token_new_eos(l,c) \ + ffelex_token_new_simple_ (FFELEX_typeEOS, (l), (c)) +#define ffelex_token_new_period(l,c) \ + ffelex_token_new_simple_ (FFELEX_typePERIOD, (l), (c)) +#define ffelex_token_strcmp(t1,t2) strcmp ((t1)->text, (t2)->text) +#define ffelex_token_text(t) ((t)->text) +#define ffelex_token_type(t) ((t)->type) +#define ffelex_token_where_column(t) ((t)->where_col) +#define ffelex_token_where_filename(t) \ + ffewhere_line_filename ((t)->where_line) +#define ffelex_token_where_filelinenum(t) \ + ffewhere_line_filelinenum((t)->where_line) +#define ffelex_token_where_line(t) ((t)->where_line) +#define ffelex_token_where_line_number(t) \ + ffewhere_line_number ((t)->where_line) +#define ffelex_token_wheretrack(t) ((t)->wheretrack) + +/* End of #include file. */ + +#endif diff --git a/gcc/f/malloc.c b/gcc/f/malloc.c new file mode 100644 index 000000000000..3b394ead563f --- /dev/null +++ b/gcc/f/malloc.c @@ -0,0 +1,565 @@ +/* malloc.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + None + + Description: + Fast pool-based memory allocation. + + Modifications: +*/ + +/* Include files. */ + +#include "proj.h" +#include "malloc.h" + +/* For systems where is missing: */ + +void *malloc (size_t size); +void *realloc (void *ptr, size_t size); + +/* Externals defined here. */ + +struct _malloc_root_ malloc_root_ += +{ + { + &malloc_root_.malloc_pool_image_, + &malloc_root_.malloc_pool_image_, + (mallocPool) &malloc_root_.malloc_pool_image_.eldest, + (mallocPool) &malloc_root_.malloc_pool_image_.eldest, + (mallocArea_) &malloc_root_.malloc_pool_image_.first, + (mallocArea_) &malloc_root_.malloc_pool_image_.first, + 0, +#if MALLOC_DEBUG + 0, 0, 0, 0, 0, 0, 0, '/' +#endif + }, +}; + +/* Simple definitions and enumerations. */ + + +/* Internal typedefs. */ + + +/* Private include files. */ + + +/* Internal structure definitions. */ + + +/* Static objects accessed by functions in this module. */ + +static void *malloc_reserve_ = NULL; /* For crashes. */ +#if MALLOC_DEBUG +static char *malloc_types_[] = +{"KS", "KSR", "NF", "NFR", "US", "USR"}; +#endif + +/* Static functions (internal). */ + +static void malloc_kill_area_ (mallocPool pool, mallocArea_ a); +#if MALLOC_DEBUG +static void malloc_verify_area_ (mallocPool pool, mallocArea_ a); +#endif + +/* Internal macros. */ + +#if MALLOC_DEBUG +#define malloc_kill_(ptr,s) do {memset((ptr),127,(s));free((ptr));} while(0) +#else +#define malloc_kill_(ptr,s) free((ptr)) +#endif + +/* malloc_kill_area_ -- Kill storage area and its object + + malloc_kill_area_(mallocPool pool,mallocArea_ area); + + Does the actual killing of a storage area. */ + +static void +malloc_kill_area_ (mallocPool pool UNUSED, mallocArea_ a) +{ +#if MALLOC_DEBUG + assert (strcmp (a->name, ((char *) (a->where)) + a->size) == 0); +#endif + malloc_kill_ (a->where, a->size); + a->next->previous = a->previous; + a->previous->next = a->next; +#if MALLOC_DEBUG + pool->freed += a->size; + pool->frees++; +#endif + malloc_kill_ (a, + offsetof (struct _malloc_area_, name) + + strlen (a->name) + 1); +} + +/* malloc_verify_area_ -- Verify storage area and its object + + malloc_verify_area_(mallocPool pool,mallocArea_ area); + + Does the actual verifying of a storage area. */ + +#if MALLOC_DEBUG +static void +malloc_verify_area_ (mallocPool pool UNUSED, mallocArea_ a UNUSED) +{ + mallocSize s = a->size; + + assert (strcmp (a->name, ((char *) (a->where)) + s) == 0); +} +#endif + +/* malloc_init -- Initialize malloc cluster + + malloc_init(); + + Call malloc_init before you do anything else. */ + +void +malloc_init () +{ + if (malloc_reserve_ != NULL) + return; + malloc_reserve_ = malloc (20 * 1024); /* In case of crash, free this first. */ + assert (malloc_reserve_ != NULL); +} + +/* malloc_pool_display -- Display a pool + + mallocPool p; + malloc_pool_display(p); + + Displays information associated with the pool and its subpools. */ + +void +malloc_pool_display (mallocPool p UNUSED) +{ +#if MALLOC_DEBUG + mallocPool q; + mallocArea_ a; + + fprintf (dmpout, "Pool \"%s\": bytes allocated=%lu, freed=%lu, old sizes=%lu, new sizes\ +=%lu,\n allocations=%lu, frees=%lu, resizes=%lu, uses=%lu\n Subpools:\n", + p->name, p->allocated, p->freed, p->old_sizes, p->new_sizes, p->allocations, + p->frees, p->resizes, p->uses); + + for (q = p->eldest; q != (mallocPool) & p->eldest; q = q->next) + fprintf (dmpout, " \"%s\"\n", q->name); + + fprintf (dmpout, " Storage areas:\n"); + + for (a = p->first; a != (mallocArea_) & p->first; a = a->next) + { + fprintf (dmpout, " "); + malloc_display_ (a); + } +#endif +} + +/* malloc_pool_kill -- Destroy a pool + + mallocPool p; + malloc_pool_kill(p); + + Releases all storage associated with the pool and its subpools. */ + +void +malloc_pool_kill (mallocPool p) +{ + mallocPool q; + mallocArea_ a; + + if (--p->uses != 0) + return; + +#if 0 + malloc_pool_display (p); +#endif + + assert (p->next->previous == p); + assert (p->previous->next == p); + + /* Kill off all the subpools. */ + + while ((q = p->eldest) != (mallocPool) &p->eldest) + { + q->uses = 1; /* Force the kill. */ + malloc_pool_kill (q); + } + + /* Now free all the storage areas. */ + + while ((a = p->first) != (mallocArea_) & p->first) + { + malloc_kill_area_ (p, a); + } + + /* Now remove from list of sibling pools. */ + + p->next->previous = p->previous; + p->previous->next = p->next; + + /* Finally, free the pool itself. */ + + malloc_kill_ (p, + offsetof (struct _malloc_pool_, name) + + strlen (p->name) + 1); +} + +/* malloc_pool_new -- Make a new pool + + mallocPool p; + p = malloc_pool_new("My new pool",malloc_pool_image(),1024); + + Makes a new pool with the given name and default new-chunk allocation. */ + +mallocPool +malloc_pool_new (char *name, mallocPool parent, + unsigned long chunks UNUSED) +{ + mallocPool p; + + if (parent == NULL) + parent = malloc_pool_image (); + + p = malloc_new_ (offsetof (struct _malloc_pool_, name) + + (MALLOC_DEBUG ? strlen (name) + 1 : 0)); + p->next = (mallocPool) &(parent->eldest); + p->previous = parent->youngest; + parent->youngest->next = p; + parent->youngest = p; + p->eldest = (mallocPool) &(p->eldest); + p->youngest = (mallocPool) &(p->eldest); + p->first = (mallocArea_) &(p->first); + p->last = (mallocArea_) &(p->first); + p->uses = 1; +#if MALLOC_DEBUG + p->allocated = p->freed = p->old_sizes = p->new_sizes = p->allocations + = p->frees = p->resizes = 0; + strcpy (p->name, name); +#endif + return p; +} + +/* malloc_pool_use -- Use an existing pool + + mallocPool p; + p = malloc_pool_new(pool); + + Increments use count for pool; means a matching malloc_pool_kill must + be performed before a subsequent one will actually kill the pool. */ + +mallocPool +malloc_pool_use (mallocPool pool) +{ + ++pool->uses; + return pool; +} + +/* malloc_display_ -- Display info on a mallocArea_ + + mallocArea_ a; + malloc_display_(a); + + Simple. */ + +void +malloc_display_ (mallocArea_ a UNUSED) +{ +#if MALLOC_DEBUG + fprintf (dmpout, "At %08lX, size=%" mallocSize_f "u, type=%s, \"%s\"\n", + (unsigned long) a->where, a->size, malloc_types_[a->type], a->name); +#endif +} + +/* malloc_find_inpool_ -- Find mallocArea_ for object in pool + + mallocPool pool; + void *ptr; + mallocArea_ a; + a = malloc_find_inpool_(pool,ptr); + + Search for object in list of mallocArea_s, die if not found. */ + +mallocArea_ +malloc_find_inpool_ (mallocPool pool, void *ptr) +{ + mallocArea_ a; + mallocArea_ b = (mallocArea_) &pool->first; + int n = 0; + + for (a = pool->first; a != (mallocArea_) &pool->first; a = a->next) + { + assert (("Infinite loop detected" != NULL) && (a != b)); + if (a->where == ptr) + return a; + ++n; + if (n & 1) + b = b->next; + } + assert ("Couldn't find object in pool!" == NULL); + return NULL; +} + +/* malloc_kill_inpool_ -- Kill object + + malloc_kill_inpool_(NULL,MALLOC_typeUS_,ptr,size_in_bytes); + + Find the mallocArea_ for the pointer, make sure the type is proper, and + kill both of them. */ + +void +malloc_kill_inpool_ (mallocPool pool, mallocType_ type UNUSED, + void *ptr, mallocSize s UNUSED) +{ + mallocArea_ a; + + if (pool == NULL) + pool = malloc_pool_image (); + +#if MALLOC_DEBUG + assert ((pool == malloc_pool_image ()) + || malloc_pool_find_ (pool, malloc_pool_image ())); +#endif + + a = malloc_find_inpool_ (pool, ptr); +#if MALLOC_DEBUG + assert (a->type == type); + if ((type != MALLOC_typeUS_) && (type != MALLOC_typeUSR_)) + assert (a->size == s); +#endif + malloc_kill_area_ (pool, a); +} + +/* malloc_new_ -- Allocate new object, die if unable + + ptr = malloc_new_(size_in_bytes); + + Call malloc, bomb if it returns NULL. */ + +void * +malloc_new_ (mallocSize s) +{ + void *ptr; + size_t ss = s; + +#if MALLOC_DEBUG + assert (s == (mallocSize) ss);/* Else alloc is too big for this + library/sys. */ +#endif + + ptr = malloc (ss); + if (ptr == NULL) + { + free (malloc_reserve_); + assert (ptr != NULL); + } +#if MALLOC_DEBUG + memset (ptr, 126, ss); /* Catch some kinds of errors more + quickly/reliably. */ +#endif + return ptr; +} + +/* malloc_new_inpool_ -- Allocate new object, die if unable + + ptr = malloc_new_inpool_(NULL,MALLOC_typeUS_,"object",size_in_bytes); + + Allocate the structure and allocate a mallocArea_ to describe it, then + add it to the list of mallocArea_s for the pool. */ + +void * +malloc_new_inpool_ (mallocPool pool, mallocType_ type, char *name, mallocSize s) +{ + void *ptr; + mallocArea_ a; + unsigned short i; + + if (pool == NULL) + pool = malloc_pool_image (); + +#if MALLOC_DEBUG + assert ((pool == malloc_pool_image ()) + || malloc_pool_find_ (pool, malloc_pool_image ())); +#endif + + ptr = malloc_new_ (s + (i = (MALLOC_DEBUG ? strlen (name) + 1 : 0))); +#if MALLOC_DEBUG + strcpy (((char *) (ptr)) + s, name); +#endif + a = malloc_new_ (offsetof (struct _malloc_area_, name) + i); + switch (type) + { /* A little optimization to speed up killing + of non-permanent stuff. */ + case MALLOC_typeKP_: + case MALLOC_typeKPR_: + a->next = (mallocArea_) &pool->first; + break; + + default: + a->next = pool->first; + break; + } + a->previous = a->next->previous; + a->next->previous = a; + a->previous->next = a; + a->where = ptr; +#if MALLOC_DEBUG + a->size = s; + a->type = type; + strcpy (a->name, name); + pool->allocated += s; + pool->allocations++; +#endif + return ptr; +} + +/* malloc_new_zinpool_ -- Allocate new zeroed object, die if unable + + ptr = malloc_new_zinpool_(NULL,MALLOC_typeUS_,"object",size_in_bytes,0); + + Like malloc_new_inpool_, but zeros out all the bytes in the area (assuming + you pass it a 0). */ + +void * +malloc_new_zinpool_ (mallocPool pool, mallocType_ type, char *name, mallocSize s, + int z) +{ + void *ptr; + + ptr = malloc_new_inpool_ (pool, type, name, s); + memset (ptr, z, s); + return ptr; +} + +/* malloc_pool_find_ -- See if pool is a descendant of another pool + + if (malloc_pool_find_(target_pool,parent_pool)) ...; + + Recursive descent on each of the children of the parent pool, after + first checking the children themselves. */ + +char +malloc_pool_find_ (mallocPool pool, mallocPool parent) +{ + mallocPool p; + + for (p = parent->eldest; p != (mallocPool) & parent->eldest; p = p->next) + { + if ((p == pool) || malloc_pool_find_ (pool, p)) + return 1; + } + return 0; +} + +/* malloc_resize_inpool_ -- Resize existing object in pool + + ptr = malloc_resize_inpool_(NULL,MALLOC_typeUSR_,ptr,new_size,old_size); + + Find the object's mallocArea_, check it out, then do the resizing. */ + +void * +malloc_resize_inpool_ (mallocPool pool, mallocType_ type UNUSED, + void *ptr, mallocSize ns, mallocSize os UNUSED) +{ + mallocArea_ a; + + if (pool == NULL) + pool = malloc_pool_image (); + +#if MALLOC_DEBUG + assert ((pool == malloc_pool_image ()) + || malloc_pool_find_ (pool, malloc_pool_image ())); +#endif + + a = malloc_find_inpool_ (pool, ptr); +#if MALLOC_DEBUG + assert (a->type == type); + if ((type == MALLOC_typeKSR_) || (type == MALLOC_typeKPR_)) + assert (a->size == os); + assert (strcmp (a->name, ((char *) (ptr)) + os) == 0); +#endif + ptr = malloc_resize_ (ptr, ns + (MALLOC_DEBUG ? strlen (a->name) + 1: 0)); + a->where = ptr; +#if MALLOC_DEBUG + a->size = ns; + strcpy (((char *) (ptr)) + ns, a->name); + pool->old_sizes += os; + pool->new_sizes += ns; + pool->resizes++; +#endif + return ptr; +} + +/* malloc_resize_ -- Reallocate object, die if unable + + ptr = malloc_resize_(ptr,size_in_bytes); + + Call realloc, bomb if it returns NULL. */ + +void * +malloc_resize_ (void *ptr, mallocSize s) +{ + size_t ss = s; + +#if MALLOC_DEBUG + assert (s == (mallocSize) ss);/* Too big if failure here. */ +#endif + + ptr = realloc (ptr, ss); + if (ptr == NULL) + { + free (malloc_reserve_); + assert (ptr != NULL); + } + return ptr; +} + +/* malloc_verify_inpool_ -- Verify object + + Find the mallocArea_ for the pointer, make sure the type is proper, and + verify both of them. */ + +void +malloc_verify_inpool_ (mallocPool pool UNUSED, mallocType_ type UNUSED, + void *ptr UNUSED, mallocSize s UNUSED) +{ +#if MALLOC_DEBUG + mallocArea_ a; + + if (pool == NULL) + pool = malloc_pool_image (); + + assert ((pool == malloc_pool_image ()) + || malloc_pool_find_ (pool, malloc_pool_image ())); + + a = malloc_find_inpool_ (pool, ptr); + assert (a->type == type); + if ((type != MALLOC_typeUS_) && (type != MALLOC_typeUSR_)) + assert (a->size == s); + malloc_verify_area_ (pool, a); +#endif +} diff --git a/gcc/f/malloc.h b/gcc/f/malloc.h new file mode 100644 index 000000000000..3d3cd50c404f --- /dev/null +++ b/gcc/f/malloc.h @@ -0,0 +1,183 @@ +/* malloc.h -- Public #include File (module.h template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + malloc.c + + Modifications: +*/ + +/* Allow multiple inclusion to work. */ + +#ifndef _H_f_malloc +#define _H_f_malloc + +#ifndef MALLOC_DEBUG +#define MALLOC_DEBUG 0 /* 1 means check caller's use of this module. */ +#endif + +/* Simple definitions and enumerations. */ + +typedef enum + { + MALLOC_typeKS_, + MALLOC_typeKSR_, + MALLOC_typeKP_, + MALLOC_typeKPR_, + MALLOC_typeUS_, + MALLOC_typeUSR_, + MALLOC_type_ + } mallocType_; + +/* Typedefs. */ + +typedef struct _malloc_area_ *mallocArea_; +typedef struct _malloc_pool_ *mallocPool; +typedef unsigned long int mallocSize; +#define mallocSize_f "l" + +/* Include files needed by this one. */ + + +/* Structure definitions. */ + +struct _malloc_area_ + { + mallocArea_ next; + mallocArea_ previous; + void *where; +#if MALLOC_DEBUG + mallocSize size; + mallocType_ type; +#endif + char name[1]; + }; + +struct _malloc_pool_ + { + mallocPool next; + mallocPool previous; + mallocPool eldest; + mallocPool youngest; + mallocArea_ first; + mallocArea_ last; + unsigned long uses; +#if MALLOC_DEBUG + mallocSize allocated; + mallocSize freed; + mallocSize old_sizes; + mallocSize new_sizes; + unsigned long allocations; + unsigned long frees; + unsigned long resizes; +#endif + char name[1]; + }; + +struct _malloc_root_ + { + struct _malloc_pool_ malloc_pool_image_; + }; + +/* Global objects accessed by users of this module. */ + +extern struct _malloc_root_ malloc_root_; + +/* Declare functions with prototypes. */ + +void malloc_display_ (mallocArea_ a); +mallocArea_ malloc_find_inpool_ (mallocPool pool, void *ptr); +void malloc_init (void); +void malloc_kill_inpool_ (mallocPool pool, mallocType_ type, void *ptr, + mallocSize size); +void *malloc_new_ (mallocSize size); +void *malloc_new_inpool_ (mallocPool pool, mallocType_ type, char *name, + mallocSize size); +void *malloc_new_zinpool_ (mallocPool pool, mallocType_ type, char *name, + mallocSize size, int z); +void malloc_pool_display (mallocPool p); +char malloc_pool_find_ (mallocPool p, mallocPool parent); +void malloc_pool_kill (mallocPool p); +mallocPool malloc_pool_new (char *name, mallocPool parent, unsigned long chunks); +mallocPool malloc_pool_use (mallocPool p); +void *malloc_resize_ (void *ptr, mallocSize new_size); +void *malloc_resize_inpool_ (mallocPool pool, mallocType_ type, void *ptr, + mallocSize new_size, mallocSize old_size); +void malloc_verify_inpool_ (mallocPool pool, mallocType_ type, void *ptr, + mallocSize size); + +/* Define macros. */ + +#define malloc_new_ks(pool,name,size) \ + malloc_new_inpool_ (pool,MALLOC_typeKS_,name,size) +#define malloc_new_ksr(pool,name,size) \ + malloc_new_inpool_ (pool,MALLOC_typeKSR_,name,size) +#define malloc_new_kp(pool,name,size) \ + malloc_new_inpool_ (pool,MALLOC_typeKP_,name,size) +#define malloc_new_kpr(pool,name,size) \ + malloc_new_inpool_ (pool,MALLOC_typeKPR_,name,size) +#define malloc_new_us(pool,name,size) \ + malloc_new_inpool_ (pool,MALLOC_typeUS_,name,size) +#define malloc_new_usr(pool,name,size) \ + malloc_new_inpool_ (pool,MALLOC_typeUSR_,name,size) +#define malloc_new_zks(pool,name,size,z) \ + malloc_new_zinpool_ (pool,MALLOC_typeKS_,name,size,z) +#define malloc_new_zksr(pool,name,size,z) \ + malloc_new_zinpool_ (pool,MALLOC_typeKSR_,name,size,z) +#define malloc_new_zkp(pool,name,size,z) \ + malloc_new_zinpool_ (pool,MALLOC_typeKP_,name,size,z) +#define malloc_new_zkpr(pool,name,size,z) \ + malloc_new_zinpool_ (pool,MALLOC_typeKPR_,name,size,z) +#define malloc_new_zus(pool,name,size,z) \ + malloc_new_zinpool_ (pool,MALLOC_typeUS_,name,size,z) +#define malloc_new_zusr(pool,name,size,z) \ + malloc_new_zinpool_ (pool,MALLOC_typeUSR_,name,size,z) +#define malloc_kill_ks(pool,ptr,size) \ + malloc_kill_inpool_ (pool,MALLOC_typeKS_,ptr,size) +#define malloc_kill_ksr(pool,ptr,size) \ + malloc_kill_inpool_ (pool,MALLOC_typeKSR_,ptr,size) +#define malloc_kill_us(pool,ptr) \ + malloc_kill_inpool_ (pool,MALLOC_typeUS_,ptr,0) +#define malloc_kill_usr(pool,ptr) \ + malloc_kill_inpool_ (pool,MALLOC_typeUSR_,ptr,0) +#define malloc_pool_image() (&malloc_root_.malloc_pool_image_) +#define malloc_resize_ksr(pool,ptr,new_size,old_size) \ + malloc_resize_inpool_ (pool,MALLOC_typeKSR_,ptr,new_size,old_size) +#define malloc_resize_kpr(pool,ptr,new_size,old_size) \ + malloc_resize_inpool_ (pool,MALLOC_typeKPR_,ptr,new_size,old_size) +#define malloc_resize_usr(pool,ptr,new_size) \ + malloc_resize_inpool_ (pool,MALLOC_typeUSR_,ptr,new_size,0) +#define malloc_verify_kp(pool,name,size) \ + malloc_verify_inpool_ (pool,MALLOC_typeKP_,name,size) +#define malloc_verify_kpr(pool,name,size) \ + malloc_verify_inpool_ (pool,MALLOC_typeKPR_,name,size) +#define malloc_verify_ks(pool,ptr,size) \ + malloc_verify_inpool_ (pool,MALLOC_typeKS_,ptr,size) +#define malloc_verify_ksr(pool,ptr,size) \ + malloc_verify_inpool_ (pool,MALLOC_typeKSR_,ptr,size) +#define malloc_verify_us(pool,ptr) \ + malloc_verify_inpool_ (pool,MALLOC_typeUS_,ptr,0) +#define malloc_verify_usr(pool,ptr) \ + malloc_verify_inpool_ (pool,MALLOC_typeUSR_,ptr,0) + +/* End of #include file. */ + +#endif diff --git a/gcc/f/name.c b/gcc/f/name.c new file mode 100644 index 000000000000..0d85863611f8 --- /dev/null +++ b/gcc/f/name.c @@ -0,0 +1,242 @@ +/* name.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + None. + + Description: + Name and name space abstraction. + + Modifications: +*/ + +/* Include files. */ + +#include "proj.h" +#include "bad.h" +#include "name.h" +#include "lex.h" +#include "malloc.h" +#include "src.h" +#include "where.h" + +/* Externals defined here. */ + + +/* Simple definitions and enumerations. */ + + +/* Internal typedefs. */ + + +/* Private include files. */ + + +/* Internal structure definitions. */ + + +/* Static objects accessed by functions in this module. */ + + +/* Static functions (internal). */ + +static ffename ffename_lookup_ (ffenameSpace ns, ffelexToken t, bool *found); + +/* Internal macros. */ + + +/* Searches for and returns the matching ffename object, or returns a + pointer to the name before which the new name should go. */ + +static ffename +ffename_lookup_ (ffenameSpace ns, ffelexToken t, bool *found) +{ + ffename n; + + for (n = ns->first; n != (ffename) &ns->first; n = n->next) + { + if (ffelex_token_strcmp (t, n->t) == 0) + { + *found = TRUE; + return n; + } + } + + *found = FALSE; + return n; /* (n == (ffename) &ns->first) */ +} + +/* Searches for and returns the matching ffename object, or creates a new + one (with a NULL ffesymbol) and returns that. If last arg is TRUE, + check whether token meets character-content requirements (such as + "all characters must be uppercase", as determined by + ffesrc_bad_char_symbol (), issue diagnostic if it doesn't. */ + +ffename +ffename_find (ffenameSpace ns, ffelexToken t) +{ + ffename n; + ffename newn; + bool found; + + assert (ns != NULL); + assert ((t != NULL) && ((ffelex_token_type (t) == FFELEX_typeNAME) + || (ffelex_token_type (t) == FFELEX_typeNAMES))); + + n = ffename_lookup_ (ns, t, &found); + if (found) + return n; + + newn = (ffename) malloc_new_ks (ns->pool, "FFENAME name", sizeof (*n)); + newn->next = n; + newn->previous = n->previous; + n->previous = newn; + newn->previous->next = newn; + newn->t = ffelex_token_use (t); + newn->u.s = NULL; + + return newn; +} + +/* ffename_kill -- Kill name from name space + + ffenameSpace ns; + ffename s; + ffename_kill(ns,s); + + Removes the name from the name space. */ + +void +ffename_kill (ffenameSpace ns, ffename n) +{ + assert (ns != NULL); + assert (n != NULL); + + ffelex_token_kill (n->t); + n->next->previous = n->previous; + n->previous->next = n->next; + malloc_kill_ks (ns->pool, n, sizeof (*n)); +} + +/* ffename_lookup -- Look up name in name space + + ffenameSpace ns; + ffelexToken t; + ffename s; + n = ffename_lookup(ns,t); + + Searches for and returns the matching ffename object, or returns NULL. */ + +ffename +ffename_lookup (ffenameSpace ns, ffelexToken t) +{ + ffename n; + bool found; + + assert (ns != NULL); + assert ((t != NULL) && ((ffelex_token_type (t) == FFELEX_typeNAME) + || (ffelex_token_type (t) == FFELEX_typeNAMES))); + + n = ffename_lookup_ (ns, t, &found); + + return found ? n : NULL; +} + +/* ffename_space_drive_global -- Call given fn for each global in name space + + ffenameSpace ns; + ffeglobal (*fn)(); + ffename_space_drive_global(ns,fn); */ + +void +ffename_space_drive_global (ffenameSpace ns, ffeglobal (*fn) ()) +{ + ffename n; + + if (ns == NULL) + return; + + for (n = ns->first; n != (ffename) &ns->first; n = n->next) + { + if (n->u.g != NULL) + n->u.g = (*fn) (n->u.g); + } +} + +/* ffename_space_drive_symbol -- Call given fn for each symbol in name space + + ffenameSpace ns; + ffesymbol (*fn)(); + ffename_space_drive_symbol(ns,fn); */ + +void +ffename_space_drive_symbol (ffenameSpace ns, ffesymbol (*fn) ()) +{ + ffename n; + + if (ns == NULL) + return; + + for (n = ns->first; n != (ffename) &ns->first; n = n->next) + { + if (n->u.s != NULL) + n->u.s = (*fn) (n->u.s); + } +} + +/* ffename_space_kill -- Kill name space + + ffenameSpace ns; + ffename_space_kill(ns); + + Removes the names from the name space; kills the name space. */ + +void +ffename_space_kill (ffenameSpace ns) +{ + assert (ns != NULL); + + while (ns->first != (ffename) &ns->first) + ffename_kill (ns, ns->first); + + malloc_kill_ks (ns->pool, ns, sizeof (*ns)); +} + +/* ffename_space_new -- Create name space + + ffenameSpace ns; + ns = ffename_space_new(malloc_pool_image()); + + Create new name space. */ + +ffenameSpace +ffename_space_new (mallocPool pool) +{ + ffenameSpace ns; + + ns = (ffenameSpace) malloc_new_ks (pool, "FFENAME space", + sizeof (*ns)); + ns->first = (ffename) &ns->first; + ns->last = (ffename) &ns->first; + ns->pool = pool; + + return ns; +} diff --git a/gcc/f/name.h b/gcc/f/name.h new file mode 100644 index 000000000000..e73d9504aa15 --- /dev/null +++ b/gcc/f/name.h @@ -0,0 +1,109 @@ +/* name.h -- Public #include File (module.h template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + name.c + + Modifications: +*/ + +/* Allow multiple inclusion to work. */ + +#ifndef _H_f_name +#define _H_f_name + +/* Simple definitions and enumerations. */ + + +/* Typedefs. */ + +typedef struct _ffename_ *ffename; +typedef struct _ffename_space_ *ffenameSpace; + +/* Include files needed by this one. */ + +#include "global.h" +#include "lex.h" +#include "malloc.h" +#include "symbol.h" + +/* Structure definitions. */ + +struct _ffename_ + { + ffename next; + ffename previous; + ffelexToken t; + union + { + ffesymbol s; + ffeglobal g; + } + u; + }; + +struct _ffename_space_ + { + ffename first; + ffename last; + mallocPool pool; + }; + +/* Global objects accessed by users of this module. */ + + +/* Declare functions with prototypes. */ + +ffename ffename_find (ffenameSpace ns, ffelexToken t); +void ffename_kill (ffenameSpace ns, ffename n); +ffename ffename_lookup (ffenameSpace ns, ffelexToken t); +void ffename_space_drive_global (ffenameSpace ns, ffeglobal (*fn) ()); +void ffename_space_drive_symbol (ffenameSpace ns, ffesymbol (*fn) ()); +void ffename_space_kill (ffenameSpace ns); +ffenameSpace ffename_space_new (mallocPool pool); + +/* Define macros. */ + +#define ffename_first_token(n) ((n)->t) +#define ffename_global(n) ((n)->u.g) +#define ffename_init_0() +#define ffename_init_1() +#define ffename_init_2() +#define ffename_init_3() +#define ffename_init_4() +#define ffename_set_global(n,glob) ((n)->u.g = (glob)) +#define ffename_set_symbol(n,sym) ((n)->u.s = (sym)) +#define ffename_symbol(n) ((n)->u.s) +#define ffename_terminate_0() +#define ffename_terminate_1() +#define ffename_terminate_2() +#define ffename_terminate_3() +#define ffename_terminate_4() +#define ffename_text(n) ffelex_token_text((n)->t) +#define ffename_token(n) ((n)->t) +#define ffename_where_filename(n) ffelex_token_where_filename((n)->t) +#define ffename_where_filelinenum(n) ffelex_token_where_filelinenum((n)->t) +#define ffename_where_line(n) ffelex_token_where_line((n)->t) +#define ffename_where_column(n) ffelex_token_where_column((n)->t) + +/* End of #include file. */ + +#endif diff --git a/gcc/f/news.texi b/gcc/f/news.texi new file mode 100644 index 000000000000..efb599645aaa --- /dev/null +++ b/gcc/f/news.texi @@ -0,0 +1,1468 @@ +@c Copyright (C) 1995-1997 Free Software Foundation, Inc. +@c This is part of the G77 manual. +@c For copying conditions, see the file g77.texi. + +@c The text of this file appears in the file BUGS +@c in the G77 distribution, as well as in the G77 manual. + +@c 1997-08-11 + +@ifclear NEWSONLY +@node News +@chapter News About GNU Fortran +@end ifclear +@cindex versions, recent +@cindex recent versions + +Changes made to recent versions of GNU Fortran are listed +below, with the most recent version first. + +The changes are generally listed with code-generation +bugs first, followed by compiler crashes involving valid +code, new features, fixes to existing features, new +diagnostics, internal improvements, and miscellany. +This order is not strict---for example, some items +involve a combination of these elements. + +@heading In 0.5.21: +@itemize @bullet +@item +Fix a code-generation bug introduced by 0.5.20 +caused by loop unrolling (by specifying +@samp{-funroll-loops} or similar). +This bug afflicted all code compiled by +version 2.7.2.2.f.2 of @code{gcc} (C, C++, +Fortran, and so on). + +@item +Fix a code-generation bug manifested when +combining local @code{EQUIVALENCE} with a +@code{DATA} statement that follows +the first executable statement (or is +treated as an executable-context statement +as a result of using the @samp{-fpedantic} +option). + +@item +Fix a compiler crash that occured when an +integer division by a constant zero is detected. +Instead, when the @samp{-W} option is specified, +the @code{gcc} back end issues a warning about such a case. +This bug afflicted all code compiled by +version 2.7.2.2.f.2 of @code{gcc} (C, C++, +Fortran, and so on). + +@item +Fix a compiler crash that occurred in some cases +of procedure inlining. +(Such cases became more frequent in 0.5.20.) + +@item +Fix a compiler crash resulting from using @code{DATA} +or similar to initialize a @code{COMPLEX} variable or +array to zero. + +@item +Fix compiler crashes involving use of @code{AND}, @code{OR}, +or @code{XOR} intrinsics. + +@item +Fix compiler bug triggered when using a @code{COMMON} +or @code{EQUIVALENCE} variable +as the target of an @code{ASSIGN} +or assigned-@code{GOTO} statement. + +@item +Fix compiler crashes due to using the name of a some +non-standard intrinsics (such as @samp{FTELL} or +@samp{FPUTC}) as such and as the name of a procedure +or common block. +Such dual use of a name in a program is allowed by +the standard. + +@c @code{g77}'s version of @code{libf2c} has been modified +@c so that the external names of library's procedures do not +@c conflict with names used for Fortran procedures compiled +@c by @code{g77}. +@c An additional layer of jacket procedures has been added +@c to @code{libf2c} to map the old names to the new names, +@c for automatic use by programs that interface to the +@c library procedures via the external-procedure mechanism. +@c +@c For example, the intrinsic @code{FPUTC} previously was +@c implemented by @code{g77} as a call to the @code{libf2c} +@c routine @samp{fputc_}. +@c This would conflict with a Fortran procedure named @code{FPUTC} +@c (using default compiler options), and this conflict +@c would cause a crash under certain circumstances. +@c +@c Now, the intrinsic @code{FPUTC} calls @samp{G77_fputc_0}, +@c which does not conflict with the @samp{fputc_} external +@c that implements a Fortran procedure named @code{FPUTC}. +@c +@c Programs that refer to @code{FPUTC} as an external procedure +@c without supplying their own implementation will link to +@c the new @code{libf2c} routine @samp{fputc_}, which is +@c simply a jacket routine that calls @samp{G77_fputc_0}. + +@item +Place automatic arrays on the stack, even if +@code{SAVE} or the @samp{-fno-automatic} option +is in effect. +This avoids a compiler crash in some cases. + +@item +New option @samp{-Wno-globals} disables warnings +about ``suspicious'' use of a name both as a global +name and as the implicit name of an intrinsic, and +warnings about disagreements over the number or natures of +arguments passed to global procedures, or the +natures of the procedures themselves. + +The default is to issue such warnings, which are +new as of this version of @code{g77}. + +@item +New option @samp{-fno-globals} disables diagnostics +about potentially fatal disagreements +analysis problems, such as disagreements over the +number or natures of arguments passed to global +procedures, or the natures of those procedures themselves. + +The default is to issue such diagnostics and flag +the compilation as unsuccessful. +With this option, the diagnostics are issued as +warnings, or, if @samp{-Wno-globals} is specified, +are not issued at all. + +This option also disables inlining of global procedures, +to avoid compiler crashes resulting from coding errors +that these diagnostics normally would identify. + +@item +Diagnose cases where a reference to a procedure +disagrees with the type of that procedure, or +where disagreements about the number or nature +of arguments exist. +This avoids a compiler crash. + +@item +Improve performance of the @code{gcc} back end so +certain complicated expressions involving @code{COMPLEX} +arithmetic (especially multiplication) don't appear to +take forever to compile. + +@item +Fix a couple of profiling-related bugs in @code{gcc} +back end. + +@item +Integrate GNU Ada's (GNAT's) changes to the back end, +which consist almost entirely of bug fixes. + +@item +Include some other @code{gcc} fixes that seem useful in +@code{g77}'s version of @code{gcc}. +(See @file{gcc/ChangeLog} for details---compare it +to that file in the vanilla @code{gcc-2.7.2.2.tar.gz} +distribution.) + +@item +Fix @code{libU77} routines that accept file and other names +to strip trailing blanks from them, for consistency +with other implementations. +Blanks may be forcibly appended to such names by +appending a single null character (@samp{CHAR(0)}) +to the significant trailing blanks. + +@item +Fix @code{CHMOD} intrinsic to work with file names +that have embedded blanks, commas, and so on. + +@item +Fix @code{SIGNAL} intrinsic so it accepts an +optional third @samp{Status} argument. + +@item +Fix @code{IDATE()} intrinsic subroutine (VXT form) +so it accepts arguments in the correct order. +Documentation fixed accordingly, and for +@code{GMTIME()} and @code{LTIME()} as well. + +@item +Make many changes to @code{libU77} intrinsics to +support existing code more directly. + +Such changes include allowing both subroutine and +function forms of many routines, changing @code{MCLOCK()} +and @code{TIME()} to return @code{INTEGER(KIND=1)} values, +introducing @code{MCLOCK8()} and @code{TIME8()} to +return @code{INTEGER(KIND=2)} values, +and placing functions that are intended to perform +side effects in a new intrinsic group, @code{badu77}. + +@item +Improve @code{libU77} so it is more portable. + +@item +Add options @samp{-fbadu77-intrinsics-delete}, +@samp{-fbadu77-intrinsics-hide}, and so on. + +@item +Fix crashes involving diagnosed or invalid code. + +@item +@code{g77} and @code{gcc} now do a somewhat better +job detecting and diagnosing arrays that are too +large to handle before these cause diagnostics +during the assembler or linker phase, a compiler +crash, or generation of incorrect code. + +@item +Improve alias analysis code to properly handle +output registers (such as the @samp{%o} registers +on the SPARC). + +@item +Add support for @code{restrict} keyword in @code{gcc} +front end. + +@item +Modify @code{make} rules and related code so that +generation of Info documentation doesn't require +compilation using @code{gcc}. + +@item +Add @code{INT2} and @code{INT8} intrinsics. + +@item +Add @code{CPU_TIME} intrinsic. + +@item +Add @code{ALARM} intrinsic. + +@item +@code{CTIME} intrinsic now accepts any @code{INTEGER} +argument, not just @code{INTEGER(KIND=2)}. + +@item +Warn when explicit type declaration disagrees with +the type of an intrinsic invocation. + +@item +Support @samp{*f771} entry in @code{gcc} @file{specs} file. + +@item +Fix typo in @code{make} rule @samp{g77-cross}, used only for +cross-compiling. + +@item +Fix @code{libf2c} build procedure to re-archive library +if previous attempt to archive was interrupted. + +@item +Fix @code{gcc} to more easily support configuring on +Pentium Pro (686) systems. + +@item +Change @code{gcc} to unroll loops only during the last +invocation (of as many as two invocations) of loop +optimization. + +@item +Improve handling of @samp{-fno-f2c} so that code that +attempts to pass an intrinsic as an actual argument, +such as @samp{CALL FOO(ABS)}, is rejected due to the fact +that the run-time-library routine is, effectively, +compiled with @samp{-ff2c} in effect. + +@item +Fix @code{g77} driver to recognize @samp{-fsyntax-only} +as an option that inhibits linking, just like @samp{-c} or +@samp{-S}, and to recognize and properly handle the +@samp{-nostdlib}, @samp{-M}, @samp{-MM}, @samp{-nodefaultlibs}, +and @samp{-Xlinker} options. + +@item +Upgrade to @code{libf2c} as of 1997-08-06. + +@item +Modify @code{libf2c} to consistently and clearly diagnose +recursive I/O (at run time). + +@item +@code{g77} driver now prints version information (such as produced +by @kbd{g77 -v}) to @code{stderr} instead of @code{stdout}. + +@item +The @samp{.r} suffix now designates a Ratfor source file, +to be preprocessed via the @code{ratfor} command, available +separately. + +@item +Fix some aspects of how @code{gcc} determines what kind of +system is being configured and what kinds are supported. +For example, GNU Linux/Alpha ELF systems now are directly +supported. + +@item +Improve diagnostics. + +@item +Improve documentation and indexing. + +@item +Include all pertinent files for @code{libf2c} that come +from @code{netlib.bell-labs.com}; give any such files +that aren't quite accurate in @code{g77}'s version of +@code{libf2c} the suffix @samp{.netlib}. + +@item +Reserve @code{INTEGER(KIND=0)} for future use. +@end itemize + +@heading In 0.5.20: +@itemize @bullet +@item +The @samp{-fno-typeless-boz} option is now the default. + +This option specifies that non-decimal-radix +constants using the prefixed-radix form (such as @samp{Z'1234'}) +are to be interpreted as @code{INTEGER} constants. +Specify @samp{-ftypeless-boz} to cause such +constants to be interpreted as typeless. + +(Version 0.5.19 introduced @samp{-fno-typeless-boz} and +its inverse.) + +@item +Options @samp{-ff90-intrinsics-enable} and +@samp{-fvxt-intrinsics-enable} now are the +defaults. + +Some programs might use names that clash with +intrinsic names defined (and now enabled) by these +options or by the new @code{libU77} intrinsics. +Users of such programs might need to compile them +differently (using, for example, @samp{-ff90-intrinsics-disable}) +or, better yet, insert appropriate @code{EXTERNAL} +statements specifying that these names are not intended +to be names of intrinsics. + +@item +The @samp{ALWAYS_FLUSH} macro is no longer defined when +building @code{libf2c}, which should result in improved +I/O performance, especially over NFS. + +@emph{Note:} If you have code that depends on the behavior +of @code{libf2c} when built with @samp{ALWAYS_FLUSH} defined, +you will have to modify @code{libf2c} accordingly before +building it from this and future versions of @code{g77}. + +@item +Dave Love's implementation of @code{libU77} has been +added to the version of @code{libf2c} distributed with +and built as part of @code{g77}. +@code{g77} now knows about the routines in this library +as intrinsics. + +@item +New option @samp{-fvxt} specifies that the +source file is written in VXT Fortran, instead of GNU Fortran. + +@item +The @samp{-fvxt-not-f90} option has been deleted, +along with its inverse, @samp{-ff90-not-vxt}. + +If you used one of these deleted options, you should +re-read the pertinent documentation to determine which +options, if any, are appropriate for compiling your +code with this version of @code{g77}. + +@item +The @samp{-fugly} option now issues a warning, as it +likely will be removed in a future version. + +(Enabling all the @samp{-fugly-*} options is unlikely +to be feasible, or sensible, in the future, +so users should learn to specify only those +@samp{-fugly-*} options they really need for a +particular source file.) + +@item +The @samp{-fugly-assumed} option, introduced in +version 0.5.19, has been changed to +better accommodate old and new code. + +@item +Make a number of fixes to the @code{g77} front end and +the @code{gcc} back end to better support Alpha (AXP) +machines. +This includes providing at least one bug-fix to the +@code{gcc} back end for Alphas. + +@item +Related to supporting Alpha (AXP) machines, the @code{LOC()} +intrinsic and @code{%LOC()} construct now return +values of integer type that is the same width (holds +the same number of bits) as the pointer type on the +machine. + +On most machines, this won't make a difference, whereas +on Alphas, the type these constructs return is +@code{INTEGER*8} instead of the more common @code{INTEGER*4}. + +@item +Emulate @code{COMPLEX} arithmetic in the @code{g77} front +end, to avoid bugs in @code{complex} support in the +@code{gcc} back end. +New option @samp{-fno-emulate-complex} +causes @code{g77} to revert the 0.5.19 behavior. + +@item +Fix bug whereby @samp{REAL A(1)}, for example, caused +a compiler crash if @samp{-fugly-assumed} was in effect +and @var{A} was a local (automatic) array. +That case is no longer affected by the new +handling of @samp{-fugly-assumed}. + +@item +Fix @code{g77} command driver so that @samp{g77 -o foo.f} +no longer deletes @file{foo.f} before issuing other +diagnostics, and so the @samp{-x} option is properly +handled. + +@item +Enable inlining of subroutines and functions by the @code{gcc} +back end. +This works as it does for @code{gcc} itself---program units +may be inlined for invocations that follow them in the same +program unit, as long as the appropriate compile-time +options are specified. + +@item +Dummy arguments are no longer assumed to potentially alias +(overlap) +other dummy arguments or @code{COMMON} areas when any of +these are defined (assigned to) by Fortran code. + +This can result in faster and/or smaller programs when +compiling with optimization enabled, though on some +systems this effect is observed only when @samp{-fforce-addr} +also is specified. + +New options @samp{-falias-check}, @samp{-fargument-alias}, +@samp{-fargument-noalias}, +and @samp{-fno-argument-noalias-global} control the +way @code{g77} handles potential aliasing. + +@item +The @code{CONJG()} and @code{DCONJG()} intrinsics now +are compiled in-line. + +@item +The bug-fix for 0.5.19.1 has been re-done. +The @code{g77} compiler has been changed back to +assume @code{libf2c} has no aliasing problems in +its implementations of the @code{COMPLEX} (and +@code{DOUBLE COMPLEX}) intrinsics. +The @code{libf2c} has been changed to have no such +problems. + +As a result, 0.5.20 is expected to offer improved performance +over 0.5.19.1, perhaps as good as 0.5.19 in most +or all cases, due to this change alone. + +@emph{Note:} This change requires version 0.5.20 of +@code{libf2c}, at least, when linking code produced +by any versions of @code{g77} other than 0.5.19.1. +Use @samp{g77 -v} to determine the version numbers +of the @code{libF77}, @code{libI77}, and @code{libU77} +components of the @code{libf2c} library. +(If these version numbers are not printed---in +particular, if the linker complains about unresolved +references to names like @samp{g77__fvers__}---that +strongly suggests your installation has an obsolete +version of @code{libf2c}.) + +@item +New option @samp{-fugly-assign} specifies that the +same memory locations are to be used to hold the +values assigned by both statements @samp{I = 3} and +@samp{ASSIGN 10 TO I}, for example. +(Normally, @code{g77} uses a separate memory location +to hold assigned statement labels.) + +@item +@code{FORMAT} and @code{ENTRY} statements now are allowed to +precede @code{IMPLICIT NONE} statements. + +@item +Produce diagnostic for unsupported @code{SELECT CASE} on +@code{CHARACTER} type, instead of crashing, at compile time. + +@item +Fix crashes involving diagnosed or invalid code. + +@item +Change approach to building @code{libf2c} archive +(@file{libf2c.a}) so that members are added to it +only when truly necessary, so the user that installs +an already-built @code{g77} doesn't need to have write +access to the build tree (whereas the user doing the +build might not have access to install new software +on the system). + +@item +Support @code{gcc} version 2.7.2.2 +(modified by @code{g77} into version 2.7.2.2.f.2), +and remove +support for prior versions of @code{gcc}. + +@item +Upgrade to @code{libf2c} as of 1997-02-08, and +fix up some of the build procedures. + +@item +Improve general build procedures for @code{g77}, +fixing minor bugs (such as deletion of any file +named @file{f771} in the parent directory of @code{gcc/}). + +@item +Enable full support of @code{INTEGER*8} available in +@code{libf2c} and @file{f2c.h} so that @code{f2c} users +may make full use of its features via the @code{g77} +version of @file{f2c.h} and the @code{INTEGER*8} +support routines in the @code{g77} version of @code{libf2c}. + +@item +Improve @code{g77} driver and @code{libf2c} so that @samp{g77 -v} +yields version information on the library. + +@item +The @code{SNGL} and @code{FLOAT} intrinsics now are +specific intrinsics, instead of synonyms for the +generic intrinsic @code{REAL}. + +@item +New intrinsics have been added. +These are @code{REALPART}, @code{IMAGPART}, +@code{COMPLEX}, +@code{LONG}, and @code{SHORT}. + +@item +A new group of intrinsics, @samp{gnu}, has been added +to contain the new @code{REALPART}, @code{IMAGPART}, +and @code{COMPLEX} intrinsics. +An old group, @samp{dcp}, has been removed. + +@item +Complain about industry-wide ambiguous references +@samp{REAL(@var{expr})} and @samp{AIMAG(@var{expr})}, +where @var{expr} is @code{DOUBLE COMPLEX} (or any +complex type other than @code{COMPLEX}), unless +@samp{-ff90} option specifies Fortran 90 interpretation +or new @samp{-fugly-complex} option, in conjunction with +@samp{-fnot-f90}, specifies @code{f2c} interpretation. + +@item +Make improvements to diagnostics. + +@item +Speed up compiler a bit. + +@item +Improvements to documentation and indexing, including +a new chapter containing information on one, later +more, diagnostics that users are directed to pull +up automatically via a message in the diagnostic itself. + +(Hence the menu item @samp{M} for the node +@samp{Diagnostics} in the top-level menu of +the Info documentation.) +@end itemize + +@heading In 0.5.19.1: +@itemize @bullet +@item +Code-generation bugs afflicting operations on complex +data have been fixed. + +These bugs occurred when assigning the result of an +operation to a complex variable (or array element) +that also served as an input to that operation. + +The operations affected by this bug were: @samp{CONJG()}, +@samp{DCONJG()}, @samp{CCOS()}, @samp{CDCOS()}, +@samp{CLOG()}, @samp{CDLOG()}, @samp{CSIN()}, @samp{CDSIN()}, +@samp{CSQRT()}, @samp{CDSQRT()}, complex division, and +raising a @code{DOUBLE COMPLEX} operand to an @code{INTEGER} +power. +(The related generic and @samp{Z}-prefixed intrinsics, +such as @samp{ZSIN()}, also were affected.) + +For example, @samp{C = CSQRT(C)}, @samp{Z = Z/C}, and @samp{Z = Z**I} +(where @samp{C} is @code{COMPLEX} and @samp{Z} is +@code{DOUBLE COMPLEX}) have been fixed. +@end itemize + +@heading In 0.5.19: +@itemize @bullet +@item +Fix @code{FORMAT} statement parsing so negative values for +specifiers such as @samp{P} (e.g. @samp{FORMAT(-1PF8.1)}) +are correctly processed as negative. + +@item +Fix @code{SIGNAL} intrinsic so it once again accepts a +procedure as its second argument. + +@item +A temporary kludge option provides bare-bones information on +@code{COMMON} and @code{EQUIVALENCE} members at debug time. + +@item +New @samp{-fonetrip} option specifies FORTRAN-66-style +one-trip @code{DO} loops. + +@item +New @samp{-fno-silent} option causes names of program units +to be printed as they are compiled, in a fashion similar to +UNIX @code{f77} and @code{f2c}. + +@item +New @samp{-fugly-assumed} option specifies that arrays +dimensioned via @samp{DIMENSION X(1)}, for example, are to be +treated as assumed-size. + +@item +New @samp{-fno-typeless-boz} option specifies that non-decimal-radix +constants using the prefixed-radix form (such as @samp{Z'1234'}) +are to be interpreted as @code{INTEGER} constants. + +@item +New @samp{-ff66} option is a ``shorthand'' option that specifies +behaviors considered appropriate for FORTRAN 66 programs. + +@item +New @samp{-ff77} option is a ``shorthand'' option that specifies +behaviors considered appropriate for UNIX @code{f77} programs. + +@item +New @samp{-fugly-comma} and @samp{-fugly-logint} options provided +to perform some of what @samp{-fugly} used to do. +@samp{-fugly} and @samp{-fno-ugly} are now ``shorthand'' options, +in that they do nothing more than enable (or disable) other +@samp{-fugly-*} options. + +@item +Fix parsing of assignment statements involving targets that +are substrings of elements of @code{CHARACTER} arrays having +names such as @samp{READ}, @samp{WRITE}, @samp{GOTO}, and +@samp{REALFUNCTIONFOO}. + +@item +Fix crashes involving diagnosed code. + +@item +Fix handling of local @code{EQUIVALENCE} areas so certain cases +of valid Fortran programs are not misdiagnosed as improperly +extending the area backwards. + +@item +Support @code{gcc} version 2.7.2.1. + +@item +Upgrade to @code{libf2c} as of 1996-09-26, and +fix up some of the build procedures. + +@item +Change code generation for list-directed I/O so it allows +for new versions of @code{libf2c} that might return non-zero +status codes for some operations previously assumed to always +return zero. + +This change not only affects how @code{IOSTAT=} variables +are set by list-directed I/O, it also affects whether +@code{END=} and @code{ERR=} labels are reached by these +operations. + +@item +Add intrinsic support for new @code{FTELL} and @code{FSEEK} +procedures in @code{libf2c}. + +@item +Modify @code{fseek_()} in @code{libf2c} to be more portable +(though, in practice, there might be no systems where this +matters) and to catch invalid @samp{whence} arguments. + +@item +Some useless warnings from the @samp{-Wunused} option have +been eliminated. + +@item +Fix a problem building the @file{f771} executable +on AIX systems by linking with the @samp{-bbigtoc} option. + +@item +Abort configuration if @code{gcc} has not been patched +using the patch file provided in the @samp{gcc/f/gbe/} +subdirectory. + +@item +Add options @samp{--help} and @samp{--version} to the +@code{g77} command, to conform to GNU coding guidelines. +Also add printing of @code{g77} version number when +the @samp{--verbose} (@samp{-v}) option is used. + +@item +Change internally generated name for local @code{EQUIVALENCE} +areas to one based on the alphabetically sorted first name +in the list of names for entities placed at the beginning +of the areas. + +@item +Improvements to documentation and indexing. +@end itemize + +@heading In 0.5.18: +@itemize @bullet +@item +Add some rudimentary support for @code{INTEGER*1}, +@code{INTEGER*2}, @code{INTEGER*8}, +and their @code{LOGICAL} equivalents. +(This support works on most, maybe all, @code{gcc} targets.) + +Thanks to Scott Snyder (@email{snyder@@d0sgif.fnal.gov}) +for providing the patch for this! + +Among the missing elements from the support for these +features are full intrinsic support and constants. + +@item +Add some rudimentary support for the @code{BYTE} and +@code{WORD} type-declaration statements. +@code{BYTE} corresponds to @code{INTEGER*1}, +while @code{WORD} corresponds to @code{INTEGER*2}. + +Thanks to Scott Snyder (@email{snyder@@d0sgif.fnal.gov}) +for providing the patch for this! + +@item +The compiler code handling intrinsics has been largely +rewritten to accommodate the new types. +No new intrinsics or arguments for existing +intrinsics have been added, so there is, at this +point, no intrinsic to convert to @code{INTEGER*8}, +for example. + +@item +Support automatic arrays in procedures. + +@item +Reduce space/time requirements for handling large +@emph{sparsely} initialized aggregate arrays. +This improvement applies to only a subset of +the general problem to be addressed in 0.6. + +@item +Treat initial values of zero as if they weren't +specified (in DATA and type-declaration statements). +The initial values will be set to zero anyway, but the amount +of compile time processing them will be reduced, +in some cases significantly (though, again, this +is only a subset of the general problem to be +addressed in 0.6). + +A new option, @samp{-fzeros}, is introduced to +enable the traditional treatment of zeros as any +other value. + +@item +With @samp{-ff90} in force, @code{g77} incorrectly +interpreted @samp{REAL(Z)} as returning a @code{REAL} +result, instead of as a @code{DOUBLE PRECISION} +result. +(Here, @samp{Z} is @code{DOUBLE COMPLEX}.) + +With @samp{-fno-f90} in force, the interpretation remains +unchanged, since this appears to be how at least some +F77 code using the @code{DOUBLE COMPLEX} extension expected +it to work. + +Essentially, @samp{REAL(Z)} in F90 is the same as +@samp{DBLE(Z)}, while in extended F77, it appears to +be the same as @samp{REAL(REAL(Z))}. + +@item +An expression involving exponentiation, where both operands +were type @code{INTEGER} and the right-hand operand +was negative, was erroneously evaluated. + +@item +Fix bugs involving @code{DATA} implied-@code{DO} constructs +(these involved an errant diagnostic and a crash, both on good +code, one involving subsequent statement-function definition). + +@item +Close @code{INCLUDE} files after processing them, so compiling source +files with lots of @code{INCLUDE} statements does not result in +being unable to open @code{INCLUDE} files after all the available +file descriptors are used up. + +@item +Speed up compiling, especially of larger programs, and perhaps +slightly reduce memory utilization while compiling (this is +@emph{not} the improvement planned for 0.6 involving large aggregate +areas)---these improvements result from simply turning +off some low-level code to do self-checking that hasn't been +triggered in a long time. + +@item +Introduce three new options that +implement optimizations in the @code{gcc} back end (GBE). +These options are @samp{-fmove-all-movables}, @samp{-freduce-all-givs}, +and @samp{-frerun-loop-opt}, which are enabled, by default, +for Fortran compilations. +These optimizations are intended to help toon Fortran programs. + +@item +Patch the GBE to do a better job optimizing certain +kinds of references to array elements. + +@item +Due to patches to the GBE, the version number of @code{gcc} +also is patched to make it easier to manage installations, +especially useful if it turns out a @code{g77} change to the +GBE has a bug. + +The @code{g77}-modified version number is the @code{gcc} +version number with the string @samp{.f.@var{n}} appended, +where @samp{f} identifies the version as enhanced for +Fortran, and @var{n} is @samp{1} for the first Fortran +patch for that version of @code{gcc}, @samp{2} for the +second, and so on. + +So, this introduces version 2.7.2.f.1 of @code{gcc}. + +@item +Make several improvements and fixes to diagnostics, including +the removal of two that were inappropriate or inadequate. + +@item +Warning about two successive arithmetic operators, produced +by @samp{-Wsurprising}, now produced @emph{only} when both +operators are, indeed, arithmetic (not relational/boolean). + +@item +@samp{-Wsurprising} now warns about the remaining cases +of using non-integral variables for implied-@code{DO} +loops, instead of these being rejected unless @samp{-fpedantic} +or @samp{-fugly} specified. + +@item +Allow @code{SAVE} of a local variable or array, even after +it has been given an initial value via @code{DATA}, for example. + +@item +Introduce an Info version of @code{g77} documentation, which +supercedes @file{gcc/f/CREDITS}, @file{gcc/f/DOC}, and +@file{gcc/f/PROJECTS}. +These files will be removed in a future release. +The files @file{gcc/f/BUGS}, @file{gcc/f/INSTALL}, and +@file{gcc/f/NEWS} now are automatically built from +the texinfo source when distributions are made. + +This effort was inspired by a first pass at translating +@file{g77-0.5.16/f/DOC} that was contributed to Craig by +David Ronis (@email{ronis@@onsager.chem.mcgill.ca}). + +@item +New @samp{-fno-second-underscore} option to specify +that, when @samp{-funderscoring} is in effect, a second +underscore is not to be appended to Fortran names already +containing an underscore. + +@item +Change the way iterative @code{DO} loops work to follow +the F90 standard. +In particular, calculation of the iteration count is +still done by converting the start, end, and increment +parameters to the type of the @code{DO} variable, but +the result of the calculation is always converted to +the default @code{INTEGER} type. + +(This should have no effect on existing code compiled +by @code{g77}, but code written to assume that use +of a @emph{wider} type for the @code{DO} variable +will result in an iteration count being fully calculated +using that wider type (wider +than default @code{INTEGER}) must be rewritten.) + +@item +Support @code{gcc} version 2.7.2. + +@item +Upgrade to @code{libf2c} as of 1996-03-23, and +fix up some of the build procedures. + +Note that the email addresses related to @code{f2c} +have changed---the distribution site now is +named @code{netlib.bell-labs.com}, and the +maintainer's new address is @email{dmg@@bell-labs.com}. +@end itemize + +@heading In 0.5.17: +@itemize @bullet +@item +@strong{Fix serious bug} in @samp{g77 -v} command that can cause removal of a +system's @file{/dev/null} special file if run by user @samp{root}. + +@strong{All users} of version 0.5.16 should ensure that +they have not removed @file{/dev/null} or replaced it with an ordinary +file (e.g. by comparing the output of @samp{ls -l /dev/null} with +@samp{ls -l /dev/zero}. +If the output isn't basically the +same, contact your system +administrator about restoring @file{/dev/null} to its proper status). + +This bug is particularly insidious because removing @file{/dev/null} as +a special file can go undetected for quite a while, aside from +various applications and programs exhibiting sudden, strange +behaviors. + +I sincerely apologize for not realizing the +implications of the fact that when @samp{g77 -v} runs the @code{ld} command +with @samp{-o /dev/null} that @code{ld} tries to @emph{remove} the executable +it is supposed to build (especially if it reports unresolved +references, which it should in this case)! + +@item +Fix crash on @samp{CHARACTER*(*) FOO} in a main or block data program unit. + +@item +Fix crash that can occur when diagnostics given outside of any +program unit (such as when input file contains @samp{@@foo}). + +@item +Fix crashes, infinite loops (hangs), and such involving diagnosed code. + +@item +Fix @code{ASSIGN}'ed variables so they can be @code{SAVE}'d or dummy arguments, +and issue clearer error message in cases where target of @code{ASSIGN} +or @code{ASSIGN}ed @code{GOTO}/@code{FORMAT} is too small (which should +never happen). + +@item +Make @code{libf2c} build procedures work on more systems again by +eliminating unnecessary invocations of @samp{ld -r -x} and @samp{mv}. + +@item +Fix omission of @samp{-funix-intrinsics-@dots{}} options in list of permitted +options to compiler. + +@item +Fix failure to always diagnose missing type declaration for +@code{IMPLICIT NONE}. + +@item +Fix compile-time performance problem (which could sometimes +crash the compiler, cause a hang, or whatever, due to a bug +in the back end) involving exponentiation with a large @code{INTEGER} +constant for the right-hand operator (e.g. @samp{I**32767}). + +@item +Fix build procedures so cross-compiling @code{g77} (the @code{fini} +utility in particular) is properly built using the host compiler. + +@item +Add new @samp{-Wsurprising} option to warn about constructs that are +interpreted by the Fortran standard (and @code{g77}) in ways that +are surprising to many programmers. + +@item +Add @code{ERF()} and @code{ERFC()} as generic intrinsics mapping to existing +@code{ERF}/@code{DERF} and @code{ERFC}/@code{DERFC} specific intrinsics. + +@emph{Note:} You should +specify @samp{INTRINSIC ERF,ERFC} in any code where you might use +these as generic intrinsics, to improve likelihood of diagnostics +(instead of subtle run-time bugs) when using a compiler that +doesn't support these as intrinsics (e.g. @code{f2c}). + +@item +Remove from @samp{-fno-pedantic} the diagnostic about @code{DO} +with non-@code{INTEGER} index variable; issue that under +@samp{-Wsurprising} instead. + +@item +Clarify some diagnostics that say things like ``ignored'' when that's +misleading. + +@item +Clarify diagnostic on use of @code{.EQ.}/@code{.NE.} on @code{LOGICAL} +operands. + +@item +Minor improvements to code generation for various operations on +@code{LOGICAL} operands. + +@item +Minor improvement to code generation for some @code{DO} loops on some +machines. + +@item +Support @code{gcc} version 2.7.1. + +@item +Upgrade to @code{libf2c} as of 1995-11-15. +@end itemize + +@heading In 0.5.16: +@itemize @bullet +@item +Fix a code-generation bug involving complicated @code{EQUIVALENCE} statements +not involving @code{COMMON}. + +@item +Fix code-generation bugs involving invoking ``gratis'' library procedures +in @code{libf2c} from code compiled with @samp{-fno-f2c} by making these +procedures known to @code{g77} as intrinsics (not affected by -fno-f2c). +This is known to fix code invoking @code{ERF()}, @code{ERFC()}, +@code{DERF()}, and @code{DERFC()}. + +@item +Update @code{libf2c} to include netlib patches through 1995-08-16, and +@code{#define} @samp{WANT_LEAD_0} to 1 to make @code{g77}-compiled code more +consistent with other Fortran implementations by outputting +leading zeros in formatted and list-directed output. + +@item +Fix a code-generation bug involving adjustable dummy arrays with high +bounds whose primaries are changed during procedure execution, and +which might well improve code-generation performance for such arrays +compared to @code{f2c} plus @code{gcc} (but apparently only when using +@file{gcc-2.7.0} or later). + +@item +Fix a code-generation bug involving invocation of @code{COMPLEX} and +@code{DOUBLE COMPLEX} @code{FUNCTION}s and doing @code{COMPLEX} and +@code{DOUBLE COMPLEX} divides, when the result +of the invocation or divide is assigned directly to a variable +that overlaps one or more of the arguments to the invocation or divide. + +@item +Fix crash by not generating new optimal code for @samp{X**I} if @samp{I} is +nonconstant and the expression is used to dimension a dummy +array, since the @code{gcc} back end does not support the necessary +mechanics (and the @code{gcc} front end rejects the equivalent +construct, as it turns out). + +@item +Fix crash on expressions like @samp{COMPLEX**INTEGER}. + +@item +Fix crash on expressions like @samp{(1D0,2D0)**2}, i.e. raising a +@code{DOUBLE COMPLEX} constant to an @code{INTEGER} constant power. + +@item +Fix crashes and such involving diagnosed code. + +@item +Diagnose, instead of crashing on, statement function definitions +having duplicate dummy argument names. + +@item +Fix bug causing rejection of good code involving statement function +definitions. + +@item +Fix bug resulting in debugger not knowing size of local equivalence +area when any member of area has initial value (via @code{DATA}, +for example). + +@item +Fix installation bug that prevented installation of @code{g77} driver. +Provide for easy selection of whether to install copy of @code{g77} +as @code{f77} to replace the broken code. + +@item +Fix @code{gcc} driver (affects @code{g77} thereby) to not +gratuitously invoke the +@code{f771} program (e.g. when @samp{-E} is specified). + +@item +Fix diagnostic to point to correct source line when it immediately +follows an @code{INCLUDE} statement. + +@item +Support more compiler options in @code{gcc}/@code{g77} when +compiling Fortran files. +These options include @samp{-p}, @samp{-pg}, @samp{-aux-info}, @samp{-P}, +correct setting of version-number macros for preprocessing, full +recognition of @samp{-O0}, and +automatic insertion of configuration-specific linker specs. + +@item +Add new intrinsics that interface to existing routines in @code{libf2c}: +@code{ABORT}, @code{DERF}, @code{DERFC}, @code{ERF}, @code{ERFC}, @code{EXIT}, +@code{FLUSH}, @code{GETARG}, @code{GETENV}, @code{IARGC}, +@code{SIGNAL}, and @code{SYSTEM}. +Note that @code{ABORT}, @code{EXIT}, @code{FLUSH}, @code{SIGNAL}, and +@code{SYSTEM} are intrinsic subroutines, not functions (since they +have side effects), so to get the return values from @code{SIGNAL} +and @code{SYSTEM}, append a final argument specifying an @code{INTEGER} +variable or array element (e.g. @samp{CALL SYSTEM('rm foo',ISTAT)}). + +@item +Add new intrinsic group named @samp{unix} to contain the new intrinsics, +and by default enable this new group. + +@item +Move @code{LOC()} intrinsic out of the @samp{vxt} group to the new +@samp{unix} group. + +@item +Improve @code{g77} so that @samp{g77 -v} by itself (or with +certain other options, including @samp{-B}, @samp{-b}, @samp{-i}, +@samp{-nostdlib}, and @samp{-V}) reports lots more useful +version info, and so that long-form options @code{gcc} accepts are +understood by @code{g77} as well (even in truncated, unambiguous forms). + +@item +Add new @code{g77} option @samp{--driver=name} to specify driver when +default, @code{gcc}, isn't appropriate. + +@item +Add support for @samp{#} directives (as output by the preprocessor) in the +compiler, and enable generation of those directives by the +preprocessor (when compiling @samp{.F} files) so diagnostics and debugging +info are more useful to users of the preprocessor. + +@item +Produce better diagnostics, more like @code{gcc}, with info such as +@samp{In function `foo':} and @samp{In file included from...:}. + +@item +Support @code{gcc}'s @samp{-fident} and @samp{-fno-ident} options. + +@item +When @samp{-Wunused} in effect, don't warn about local variables used as +statement-function dummy arguments or @code{DATA} implied-@code{DO} iteration +variables, even though, strictly speaking, these are not uses +of the variables themselves. + +@item +When @samp{-W -Wunused} in effect, don't warn about unused dummy arguments +at all, since there's no way to turn this off for individual +cases (@code{g77} might someday start warning about these)---applies +to @code{gcc} versions 2.7.0 and later, since earlier versions didn't +warn about unused dummy arguments. + +@item +New option @samp{-fno-underscoring} that inhibits transformation of names +(by appending one or two underscores) so users may experiment +with implications of such an environment. + +@item +Minor improvement to @file{gcc/f/info} module to make it easier to build +@code{g77} using the native (non-@code{gcc}) compiler on certain machines +(but definitely not all machines nor all non-@code{gcc} compilers). +Please +do not report bugs showing problems compilers have with +macros defined in @file{gcc/f/target.h} and used in places like +@file{gcc/f/expr.c}. + +@item +Add warning to be printed for each invocation of the compiler +if the target machine @code{INTEGER}, @code{REAL}, or @code{LOGICAL} size +is not 32 bits, +since @code{g77} is known to not work well for such cases (to be +fixed in Version 0.6---@pxref{Actual Bugs,,Actual Bugs We Haven't Fixed Yet}). + +@item +Lots of new documentation (though work is still needed to put it into +canonical GNU format). + +@item +Build @code{libf2c} with @samp{-g0}, not @samp{-g2}, in effect +(by default), to produce +smaller library without lots of debugging clutter. +@end itemize + +@heading In 0.5.15: +@itemize @bullet +@item +Fix bad code generation involving @samp{X**I} and temporary, internal variables +generated by @code{g77} and the back end (such as for @code{DO} loops). + +@item +Fix crash given @samp{CHARACTER A;DATA A/.TRUE./}. + +@item +Replace crash with diagnostic given @samp{CHARACTER A;DATA A/1.0/}. + +@item +Fix crash or other erratic behavior when null character constant +(@samp{''}) is encountered. + +@item +Fix crash or other erratic behavior involving diagnosed code. + +@item +Fix code generation for external functions returning type @code{REAL} when +the @samp{-ff2c} option is in force (which it is by default) so that +@code{f2c} compatibility is indeed provided. + +@item +Disallow @samp{COMMON I(10)} if @samp{I} has previously been specified +with an array declarator. + +@item +New @samp{-ffixed-line-length-@var{n}} option, where @var{n} is the +maximum length +of a typical fixed-form line, defaulting to 72 columns, such +that characters beyond column @var{n} are ignored, or @var{n} is @samp{none}, +meaning no characters are ignored. +does not affect lines +with @samp{&} in column 1, which are always processed as if +@samp{-ffixed-line-length-none} was in effect. + +@item +No longer generate better code for some kinds of array references, +as @code{gcc} back end is to be fixed to do this even better, and it +turned out to slow down some code in some cases after all. + +@item +In @code{COMMON} and @code{EQUIVALENCE} areas with any members given initial +values (e.g. via @code{DATA}), uninitialized members now always +initialized to binary zeros (though this is not required by +the standard, and might not be done in future versions +of @code{g77}). +Previously, in some @code{COMMON}/@code{EQUIVALENCE} areas +(essentially those with members of more than one type), the +uninitialized members were initialized to spaces, to +cater to @code{CHARACTER} types, but it seems no existing code expects +that, while much existing code expects binary zeros. +@end itemize + +@heading In 0.5.14: +@itemize @bullet +@item +Don't emit bad code when low bound of adjustable array is nonconstant +and thus might vary as an expression at run time. + +@item +Emit correct code for calculation of number of trips in @code{DO} loops +for cases +where the loop should not execute at all. +(This bug affected cases +where the difference between the begin and end values was less +than the step count, though probably not for floating-point cases.) + +@item +Fix crash when extra parentheses surround item in +@code{DATA} implied-@code{DO} list. + +@item +Fix crash over minor internal inconsistencies in handling diagnostics, +just substitute dummy strings where necessary. + +@item +Fix crash on some systems when compiling call to @code{MVBITS()} intrinsic. + +@item +Fix crash on array assignment @samp{TYPE@var{ddd}(@dots{})=@dots{}}, where @var{ddd} +is a string of one or more digits. + +@item +Fix crash on @code{DCMPLX()} with a single @code{INTEGER} argument. + +@item +Fix various crashes involving code with diagnosed errors. + +@item +Support @samp{-I} option for @code{INCLUDE} statement, plus @code{gcc}'s +@file{header.gcc} facility for handling systems like MS-DOS. + +@item +Allow @code{INCLUDE} statement to be continued across multiple lines, +even allow it to coexist with other statements on the same line. + +@item +Incorporate Bellcore fixes to @code{libf2c} through 1995-03-15---this +fixes a bug involving infinite loops reading EOF with empty list-directed +I/O list. + +@item +Remove all the @code{g77}-specific auto-configuration scripts, code, +and so on, +except for temporary substitutes for bsearch() and strtoul(), as +too many configure/build problems were reported in these areas. +People will have to fix their systems' problems themselves, or at +least somewhere other than @code{g77}, which expects a working ANSI C +environment (and, for now, a GNU C compiler to compile @code{g77} itself). + +@item +Complain if initialized common redeclared as larger in subsequent program +unit. + +@item +Warn if blank common initialized, since its size can vary and hence +related warnings that might be helpful won't be seen. + +@item +New @samp{-fbackslash} option, on by default, that causes @samp{\} +within @code{CHARACTER} +and Hollerith constants to be interpreted a la GNU C. +Note that +this behavior is somewhat different from @code{f2c}'s, which supports only +a limited subset of backslash (escape) sequences. + +@item +Make @samp{-fugly-args} the default. + +@item +New @samp{-fugly-init} option, on by default, that allows typeless/Hollerith +to be specified as initial values for variables or named constants +(@code{PARAMETER}), and also allows character<->numeric conversion in +those contexts---turn off via @samp{-fno-ugly-init}. + +@item +New @samp{-finit-local-zero} option to initialize +local variables to binary zeros. +This does not affect whether they are @code{SAVE}d, i.e. made +automatic or static. + +@item +New @samp{-Wimplicit} option to warn about implicitly typed variables, arrays, +and functions. +(Basically causes all program units to default to @code{IMPLICIT NONE}.) + +@item +@samp{-Wall} now implies @samp{-Wuninitialized} as with @code{gcc} +(i.e. unless @samp{-O} not specified, since @samp{-Wuninitialized} +requires @samp{-O}), and implies @samp{-Wunused} as well. + +@item +@samp{-Wunused} no longer gives spurious messages for unused +@code{EXTERNAL} names (since they are assumed to refer to block data +program units, to make use of libraries more reliable). + +@item +Support @code{%LOC()} and @code{LOC()} of character arguments. + +@item +Support null (zero-length) character constants and expressions. + +@item +Support @code{f2c}'s @code{IMAG()} generic intrinsic. + +@item +Support @code{ICHAR()}, @code{IACHAR()}, and @code{LEN()} of +character expressions that are valid in assignments but +not normally as actual arguments. + +@item +Support @code{f2c}-style @samp{&} in column 1 to mean continuation line. + +@item +Allow @code{NAMELIST}, @code{EXTERNAL}, @code{INTRINSIC}, and @code{VOLATILE} +in @code{BLOCK DATA}, even though these are not allowed by the standard. + +@item +Allow @code{RETURN} in main program unit. + +@item +Changes to Hollerith-constant support to obey Appendix C of the +standard: + +@itemize -- +@item +Now padded on the right with zeros, not spaces. + +@item +Hollerith ``format specifications'' in the form of arrays of +non-character allowed. + +@item +Warnings issued when non-space truncation occurs when converting +to another type. + +@item +When specified as actual argument, now passed +by reference to @code{INTEGER} (padded on right with spaces if constant +too small, otherwise fully intact if constant wider the @code{INTEGER} +type) instead of by value. +@end itemize + +@strong{Warning:} @code{f2c} differs on the +interpretation of @samp{CALL FOO(1HX)}, which it treats exactly the +same as @samp{CALL FOO('X')}, but which the standard and @code{g77} treat +as @samp{CALL FOO(%REF('X '))} (padded with as many spaces as necessary +to widen to @code{INTEGER}), essentially. + +@item +Changes and fixes to typeless-constant support: + +@itemize -- +@item +Now treated as a typeless double-length @code{INTEGER} value. + +@item +Warnings issued when overflow occurs. + +@item +Padded on the left with zeros when converting +to a larger type. + +@item +Should be properly aligned and ordered on +the target machine for whatever type it is turned into. + +@item +When specified as actual argument, now passed as reference to +a default @code{INTEGER} constant. +@end itemize + +@item +@code{%DESCR()} of a non-@code{CHARACTER} expression now passes a pointer to +the expression plus a length for the expression just as if +it were a @code{CHARACTER} expression. +For example, @samp{CALL FOO(%DESCR(D))}, where +@samp{D} is @code{REAL*8}, is the same as @samp{CALL FOO(D,%VAL(8)))}. + +@item +Name of multi-entrypoint master function changed to incorporate +the name of the primary entry point instead of a decimal +value, so the name of the master function for @samp{SUBROUTINE X} +with alternate entry points is now @samp{__g77_masterfun_x}. + +@item +Remove redundant message about zero-step-count @code{DO} loops. + +@item +Clean up diagnostic messages, shortening many of them. + +@item +Fix typo in @code{g77} man page. + +@item +Clarify implications of constant-handling bugs in @file{f/BUGS}. + +@item +Generate better code for @samp{**} operator with a right-hand operand of +type @code{INTEGER}. + +@item +Generate better code for @code{SQRT()} and @code{DSQRT()}, +also when @samp{-ffast-math} +specified, enable better code generation for @code{SIN()} and @code{COS()}. + +@item +Generate better code for some kinds of array references. + +@item +Speed up lexing somewhat (this makes the compilation phase noticeably +faster). +@end itemize diff --git a/gcc/f/news0.texi b/gcc/f/news0.texi new file mode 100644 index 000000000000..8fb85f456da5 --- /dev/null +++ b/gcc/f/news0.texi @@ -0,0 +1,14 @@ +@setfilename NEW +@set NEWSONLY + +@c The immediately following lines apply to the NEWS file +@c which is generated using this file. +This file lists recent changes to the GNU Fortran compiler. +Copyright (C) 1995, 1996 Free Software Foundation, Inc. +You may copy, distribute, and modify it freely as long as you preserve +this copyright notice and permission notice. + +@node Top,,, (dir) +@chapter News About GNU Fortran +@include news.texi +@bye diff --git a/gcc/f/parse.c b/gcc/f/parse.c new file mode 100644 index 000000000000..7a48fbb58f55 --- /dev/null +++ b/gcc/f/parse.c @@ -0,0 +1,93 @@ +/* GNU Fortran + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. */ + +#include "proj.h" +#include +#include +#include "top.h" +#include "com.h" +#include "where.h" +#include "zzz.h" +#if FFECOM_targetCURRENT == FFECOM_targetGCC +#include "flags.j" +#endif + +#define NAME_OF_STDIN "" + +#if FFECOM_targetCURRENT == FFECOM_targetFFE +void +main (int argc, char *argv[]) +#elif FFECOM_targetCURRENT == FFECOM_targetGCC +FILE *finput; + +int +yyparse () +#else +#error +#endif +{ + ffewhereFile wf; + + if (ffe_is_version ()) + fprintf (stderr, "GNU Fortran Front End version %s compiled: %s %s\n", + ffezzz_version_string, + ffezzz_date, + ffezzz_time); + +#if FFECOM_targetCURRENT == FFECOM_targetFFE + ffe_init_0 (); + + for (--argc, ++argv; argc > 0; --argc, ++argv) + { + if (!ffe_decode_option (argv[0])) + fprintf (stderr, "Unrecognized option: %s\n", argv[0]); + } +#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 +} diff --git a/gcc/f/proj.c b/gcc/f/proj.c new file mode 100644 index 000000000000..0e1ef2e8bcd9 --- /dev/null +++ b/gcc/f/proj.c @@ -0,0 +1,71 @@ +/* proj.c file for GNU Fortran + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. */ + +#include "proj.h" +#include +#include "glimits.j" + +#if !FFEPROJ_STRTOUL +unsigned long int +strtoul (const char *nptr, char **endptr, int base) +{ + unsigned long int number = 0; + unsigned long int old_number = 0; + + assert (base == 10); + assert (endptr == NULL); + + while (isdigit (*nptr)) + { + number = old_number * 10 + (*(nptr++) - '0'); + if ((number <= old_number) && (old_number != 0)) + return ULONG_MAX; + old_number = number; + } + + return number; +} + +#endif + +#if !FFEPROJ_BSEARCH +void * +bsearch (const void *key, const void *base, size_t nmemb, size_t size, + int (*compar) (const void *, const void *)) +{ + size_t i; + int cmp; + + /* We do a dumb incremental search, not a binary search, for now. */ + + for (i = 0; i < nmemb; ++i) + { + if ((cmp = (*compar) (key, base)) == 0) + return base; + if (cmp < 0) + break; + base += size; + } + + return NULL; +} + +#endif diff --git a/gcc/f/proj.h b/gcc/f/proj.h new file mode 100644 index 000000000000..205130a49d11 --- /dev/null +++ b/gcc/f/proj.h @@ -0,0 +1,102 @@ +/* proj.h file for Gnu Fortran + Copyright (C) 1995, 1996 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + +*/ + +#ifndef _H_f_proj +#define _H_f_proj + +#if !defined (__GNUC__) || (__GNUC__ < 2) +#error "You have to use gcc 2.x to build g77 (might be fixed in g77-0.6)." +#endif + +#ifndef BUILT_WITH_270 +#if (__GNUC__ > 2) || (__GNUC__ == 2 && __GNUC_MINOR__ >= 7) +#define BUILT_WITH_270 1 +#else +#define BUILT_WITH_270 0 +#endif +#endif /* !defined (BUILT_WITH_270) */ + +/* This file used to attempt to allow for all sorts of broken systems. + Because the auto-configuration scripts in conf-proj(.in) didn't work + on all systems, and I received far too many bug reports about them, + I decided to stop trying to cater to broken systems at all, and + simply remove all but the simplest and most useful code (which is + still in proj.c). + + So, if you find your system can't link because bsearch() or strtoul() + aren't found, please just fix your system, or hand-edit the code + below as appropriate. I DO NOT WANT ANY "BUG REPORTS" ABOUT THIS. + g77 requires a working ANSI C environment, and if bsearch() and strtoul() + do not exist, or if isn't found, etc., then you don't have + one, and it is not g77's fault. If it turns out g77 is simply + referring to the wrong system header file -- something I can verify + myself using my copy of the ANSI C standard -- I would like to know + about that. Otherwise, g77 is not the place to fix problems with your + ANSI C implementation, though perhaps gcc might be. + -- burley@gnu.ai.mit.edu 1995-03-24 */ + +#ifndef FFEPROJ_BSEARCH +#define FFEPROJ_BSEARCH 1 /* 0=>use slow code in proj.c. */ +#endif +#ifndef FFEPROJ_STRTOUL +#define FFEPROJ_STRTOUL 1 /* 0=>use untested code in proj.c. */ +#endif + +/* Include files everyone gets. */ + +#include "assert.j" /* Use gcc's assert.h. */ +#include +#include +#include +#include + +/* Generally useful definitions. */ + +typedef enum + { +#if !defined(false) || !defined(true) + false = 0, true = 1, +#endif +#if !defined(FALSE) || !defined(TRUE) + FALSE = 0, TRUE = 1, +#endif + Doggone_Trailing_Comma_Dont_Work = 1 + } bool; + +#define ARRAY_SIZE(a) (sizeof(a)/sizeof(a[0])) +#define STR(s) # s +#define STRX(s) STR(s) + +#ifndef UNUSED /* Compile with -DUNUSED= if cc doesn't support this. */ +#if BUILT_WITH_270 +#define UNUSED __attribute__ ((unused)) +#else /* !BUILT_WITH_270 */ +#define UNUSED +#endif /* !BUILT_WITH_270 */ +#endif /* !defined (UNUSED) */ + +#ifndef dmpout +#define dmpout stderr +#endif + +#endif diff --git a/gcc/f/rtl.j b/gcc/f/rtl.j new file mode 100644 index 000000000000..646e1f6a4049 --- /dev/null +++ b/gcc/f/rtl.j @@ -0,0 +1,28 @@ +/* rtl.j -- Wrapper for GCC's rtl.h + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. */ + +#ifndef MAKING_DEPENDENCIES +#ifndef _J_f_rtl +#define _J_f_rtl +#include "config.j" +#include "rtl.h" +#endif +#endif diff --git a/gcc/f/runtime/ChangeLog b/gcc/f/runtime/ChangeLog new file mode 100644 index 000000000000..f5f79c899f71 --- /dev/null +++ b/gcc/f/runtime/ChangeLog @@ -0,0 +1,698 @@ +Mon Aug 11 20:12:42 1997 Craig Burley + + * Makefile.in ($(lib), stamp-lib): Ensure that library + gets fully updated even if updating was aborted earlier. + + * libU77/hostnm_.c (G77_hostnm_0): Return ENOSYS and stuff + in errno if system has no gethostname() function. + + * libU77/lstat_.c (G77_lstat_0): Return ENOSYS and stuff + in errno if system has no lstat() function. + + * libU77/getcwd_.c (G77_getcwd_0): Return ENOSYS and stuff + in errno if system has no getcwd() or getwd() function. + Test HAVE_GETCWD properly. + + * libU77/symlnk_.c (G77_symlink_0): Return ENOSYS and stuff + in errno if system has no symlink() function. + + * libU77/mclock_.c (G77_mclock_0): Return -1 if system + has no clock() function. + +Mon Aug 11 01:55:36 1997 Craig Burley + + * Makefile.in (F2CEXT): Add `alarm' to this list. + + * f2cext.c (alarm_): Fix some typos in this function. + Delete third `status' argument. + + * libU77/alarm_.c: Delete third `status' argument, + as caller gets this from function result; return + status value as function result for caller. + + * configure.in: Rename `ac_cv_struct_FILE' to + `g77_cv_struct_FILE' according to 1997-06-26 change. + +1997-08-06 Dave Love + + * libU77/vxtidate_.c: Correct day/month argument order. + * f2cext.c: Likewise. + +1997-07-07 Dave Love + + * f2cext.c: Add alarm_. + + * Makefile.in, libU77/Makefile.in: Add alarm_. + + * libU77/alarm_.c: New file. + +1997-06-26 Dave Love + + * configure.in: Generally use prefix `g77_' for cached values + we've invented, not `ac_'. + +Tue Jun 24 18:50:06 1997 Craig Burley + + * libI77/ilnw.c (s_wsni): Call f_init() here. + (s_wsli): Ditto. + (e_wsli): Turn off "doing I/O" flag here. + +1997-06-20 Dave Love + + * runtime/configure.in: Check for cygwin32 after Mumit Khan (but + differently); if cygwin32 define NON_UNIX_STDIO and don't define + NON_ANSI_RW_MODES. + +Tue Jun 01 06:26:29 1997 Craig Burley + + * libI77/rsne.c (nl_init): Don't call f_init() here, + since s_rsne() already does. + (c_lir): Call f_init() here instead. + * libI77/rsli.c (e_rsli): Turn off "doing I/O" flag here. + * libI77/sue.c (e_rsue): Ditto. + +Sun Jun 22 23:27:22 1997 Craig Burley + + * libI77/fio.h (err): Mark I/O as no longer in progress + before returning a non-zero error indicator (since + that tells the caller to jump over the remaining I/O + calls, including the corresponding `e_whatever' call). + * libI77/err.c (endif): Ditto. + * libI77/sfe.c (e_wsfe): Ditto. + * libI77/lread.c (ERR): Ditto. + * libI77/lread.c (l_read): Ditto by having quad case + use ERR, not return, to return non-zero error code. + +Sat Jun 21 12:31:28 1997 Craig Burley + + * libI77/open.c (fk_open): Temporarily turn off + "doing I/O" flag during f_open() call to avoid recursive + I/O error. + +Tue Jun 17 22:40:47 1997 Craig Burley + + * err.c, close.c, rewind.c, inquire.c, backspace.c, endfile.c, + iio.c, open.c, Version.c, sfe.c, wsle.c, rsne.c, sue.c, rsfe.c, + lread.c, wsfe.c, fio.h, due.c, dfe.c: Change f__init from + `flag' to `int' and to signal not just whether initialization + has happened (bit 0), but also whether I/O is in progress + already (bit 1). Consistently produce a clear diagnostic + in cases of recursive I/O. Avoid infinite recursion in + f__fatal, in case sig_die triggers another error. Don't + output info on internals if not initialized in f__fatal. Don't + bother closing units in f_exit if initialization hasn't + happened. + +Tue Jun 10 12:57:44 1997 Craig Burley + + Update to Netlib version of 1997-06-09: + * libI77/err.c, libI77/lread.c, libI77/rdfmt.c, + libI77/wref.c: Move some #include's around. + +Mon Jun 9 18:11:56 1997 Craig Burley + + * libU77/kill_.c (kill_): KR_headers version needed + `*' in front of args in decls. + +Sun May 25 03:16:53 1997 Craig Burley + + Update to Netlib version of 1997-05-24: + * libF77/README, libF77/Version.c, libF77/main.c, + libF77/makefile, libF77/s_paus.c, libF77/signal1.h, + libF77/signal_.c, libF77/z_div.c, libI77/Notice, + libI77/README, libI77/Version.c, libI77/dfe.c, + libI77/err.c, libI77/fmt.c, libI77/makefile, + libI77/rawio.h: Apply many, but not all, of the changes + made to libf2c since last update. + * libF77/Makefile.in (MISC), Makefile.in (MISC): Rename + exit.o to exit_.o to go along with Netlib. + * libF77/signal.c: Make the prologue much simpler than + Netlib has it. + +Sun May 18 20:56:02 1997 Craig Burley + + * libU77/unlink_.c, libU77/stat_.c, libU77/symlnk_.c, + libU77/chmod_.c: g_char first arg is const. + + * libU77/chmod_.c: s_cat expects ftnlen[], not int[] or + integer[], change types of array and variables + accordingly. + +May 7 1997 Daniel Pettet + + * libU77/dbes_.c: Commented out the code in the + same way the bes* routines are commented out. This + was done because corresponding C routines are referenced + directly in com-rt.def. + +Mon May 5 13:56:02 1997 Craig Burley + + * libU77/stat_.c: Reverse KR/ANSI decls of g_char(). + +Apr 18 1997 Daniel Pettet + + * libF77/F77_aloc.c, libF77/abort_.c, libF77/derf_.c, + libF77/derfc_.c, libF77/ef1asc_.c, libF77/ef1cmc_.c, + libF77/erf_.c, libF77/erfc_.c, libF77/exit.c, + libF77/getarg_.c, libF77/getenv_.c, libF77/iargc_.c, + libF77/s_cat.c, libF77/signal_.c, libF77/system_.c, + libI77/close.c, libI77/ftell_.c, libU77/access_.c, + libU77/bes.c, libU77/chdir_.c, libU77/chmod_.c, libU77/ctime_.c, + libU77/date_.c, libU77/dbes.c, libU77/dtime_.c, libU77/etime_.c, + libU77/fdate_.c, libU77/fgetc_.c, libU77/flush1_.c, + libU77/fnum_.c, libU77/fputc_.c, libU77/fstat_.c, + libU77/gerror_.c, libU77/getcwd_.c, libU77/getgid_.c, + libU77/getlog_.c, libU77/getpid_.c, libU77/getuid_.c, + libU77/gmtime_.c, libU77/hostnm_.c, libU77/idate_.c, + libU77/ierrno_.c, libU77/irand_.c, libU77/isatty_.c, + libU77/itime_.c, libU77/kill_.c, libU77/link_.c, + libU77/lnblnk_.c, libU77/ltime_.c, libU77/mclock_.c, + libU77/perror_.c, libU77/rand_.c, libU77/rename_.c, + libU77/secnds_.c, libU77/second_.c, libU77/sleep_.c, + libU77/srand_.c, libU77/stat_.c, libU77/symlnk_.c, + libU77/system_clock_.c, libU77/time_.c, libU77/ttynam_.c, + libU77/umask_.c, libU77/unlink_.c, libU77/vxtidate_.c, + libU77/vxttime_.c: Completed renaming routines that are directly + callable from g77 to internal names of the form + G77_xxxx_0 that are known as intrinsics by g77. + +Apr 8 1997 Daniel Pettet + + * Makefile.in: Add libU77/mclock_.o and libU77/symlnk_.o to UOBJ. + * libU77/Makefile.in: Add mclock_.c to SRCS. + Add mclock_.o and symlnk_.o to OBJS. + Add mclock_.o dependency. + +Apr 8 1997 Daniel Pettet + + * libU77/symlnk_.c: Added a couple of (char*) casts to malloc + to silence the compiler. + +1997-03-17 Dave Love + + * libU77/access_.c, libU77/chdir_.c, libU77/chmod_.c, + libU77/link_.c, libU77/lstat_.c, libU77/rename_.c, libU77/stat_.c, + libU77/symlnk_.c, libU77/u77-test.f, libU77/unlink_.c: Strip + trailing blanks from file names for consistency with other + implementations (notably Sun's). + + * libU77/chmod_.c: Quote the file name given to the shell. + +Mon Mar 10 00:19:17 1997 Craig Burley + + * libI77/uio.c (do_ud) [PAD_UDread]: Add semicolon to err() + invocation when macro not defined (from Mumit Khan + ). + +Fri Feb 28 13:16:50 1997 Craig Burley + + * Version 0.5.20 released. + +Wed Feb 26 20:28:53 1997 Craig Burley + + * Makefile.in: $(MAKE) invocations now explicitly + specify `-f Makefile', just in case the `makefile's + from the netlib distribution would get used instead. + +Mon Feb 24 16:43:39 1997 Craig Burley + + * libU77/Makefile.in (check): Specify driver, and + don't bother enabling already-enabled intrinsic groups. + Also, get the $(srcdir) version of u77-test.f. + +Sat Feb 22 14:08:42 1997 Craig Burley + + * libU77/u77-test.f: Explicitly declare intrinsics, get + rid of useless CHARACTER declarations on intrinsics (maybe + someday appropriate to implement meaning of that in g77 + and restore them?). + Add spin loop just to fatten up the timings a bit. + Clarify ETIME output as having three fields. + Call TIME with CHARACTER*8, not CHARACTER*6, argument. + Call new SECOND intrinsic subroutine, after calling + new DUMDUM subroutine just to ensure the correct value + doesn't get left around in a register or something. + +Thu Feb 20 15:22:42 1997 Craig Burley + + * libU77/bes.c: Comment out all the code, as g77 avoids actually + calling it, going directly to the system's library instead. + +Mon Feb 17 02:27:41 1997 Craig Burley + + * libU77/fgetc_.c (fgetc_): Allow return value to be + CHARACTER*(*), properly handle CHARACTER*0 and blank-pad + CHARACTER*n where n>1. + +Tue Feb 11 14:12:19 1997 Craig Burley + + * Makefile.in: Clarify role of $(srcdir) here. Fix + various targets accordingly. Don't rely at all on + gcc/f/include/ being a link to gcc/include/ -- just + use it directly. + (${srcdir}/configure, ${srcdir}/libU77/configure): + Remove the config.cache files in build directory before + cd'ing to source directory as well. + + * libF77/Makefile.in, libI77/Makefile.in (ALL_CFLAGS): + Include `-I.' to pick up build directory. + Use gcc/include/ directly. + * libU77/Makefile.in (ALL_CFLAGS): Include `-I$(srcdir)' + to pick up source directory. + (OBJS): Fix typo in `chmod_.o' (was `chmod.o'). + +Mon Feb 10 12:54:47 1997 Craig Burley + + * Makefile.in (UOBJ), libU77/Makefile.in (OBJS): Add + libU77/chmod_.o to list of objects. + * libU77/chmod_.c: Fix up headers. + Fix implementation to not prematurely truncate command + string and make room for trailing null. + + * libU77/ctime_.c: Incoming xstime argument is now longint. + * libU77/mclock_.c: Now returns longint. + * libU77/time_.c: Now returns longint. + +1997-02-10 Dave Love + + * etime_.c, dtime_.c: Typo rounded times to seconds. + + * date_.c: Add missing return. + + * hostnm_.c: #include unistd.h. + +Sat Feb 8 03:30:19 1997 Craig Burley + + INTEGER*8 support built in to f2c.h and libf2c (since + gcc will be used to compile relevant code anyway): + * Makefile.in, libF77/Makefile.in: Add pow_qq.o, + qbitbits.o, and qbitshft.o to $POW and $F90BIT macros, + as appropriate. + * f2c.h.in: Define appropriate types and macros. + Place #error directive correctly. + * configure.in: Determine appropriate types for long + integer (F2C_LONGINT). + Meanwhile, quote strings in #error, for consistency. + Fix restoring of ac_cpp macro. + * configure: Regenerated using autoconf-2.12. + + * libF77/Version.c, libI77/Version.c, libU77/Version.c: + Update version numbers. + Change names and code for g77-specific version-printing + routines (shorter names should be safer to link on + weird, 8-char systems). + + * libF77/c_cos.c, libF77/c_div.c, libF77/c_exp.c, + libF77/c_log.c, libF77/c_sin.c, libF77/c_sqrt.c, + libF77/d_cnjg.c, libF77/pow_zi.c, libF77/r_cnjg.c, + libF77/z_cos.c, libF77/z_div.c, libF77/z_exp.c, + libF77/z_log.c, libF77/z_sin.c, libF77/z_sqrt.c: + Changed to work properly even when result is aliased + with any inputs. + + * libF77/makefile, libI77/makefile: Leave these in + the g77 distribution, so it is easier to track changes + to official libf2c. + + * libF77/signal_.c: Eliminate redundant `return 0;'. + + * libI77/fio.h (err, errfl): Fix these so they work + (and must be expressed) as statements. + Fix up many users of err() to include trailing semicolon. + + * Incorporate changes by Bell Labs to libf2c through 1997-02-07. + +1997-02-06 Dave Love + + * libU77/etime_.c, libU77/dtime_.c: Fix getrusage stuff. + + * libU77/config.h.in: Regenerate for HAVE_GETRUSAGE. + + * libU77/Makefile.in, libI77/Makefile.in, libF77/Makefile.in: + Redo *clean targets; distclean and maintainer-clean remove the stage? + and include links. This probably want looking at further. + +Wed Feb 5 00:21:23 1997 Craig Burley + + Add libU77 library from Dave Love : + * Makefile.in: Add libU77 directory, rules, etc. + * configure.in: New libU77 directory, Makefile, etc. + + * Makefile.in, libF77/Makefile.in, libI77/Makefile.in, + libU77/Makefile.in: Reorganize these so $(AR) commands + handled by the top-level Makefile instead of the + subordinates. This permits it to do $(AR) only when + one or more object files actually change, instead of + having to force-update it as was necessary before. + And that had the disadvantage of requiring, e.g., user + root to have access to $(AR) to the library simply to + install g77, which might be problematic on an NFS setup. + (mostlyclean, clean, distclean, maintainer-clean): + Properly handle these rules. + + * Makefile.in: Don't invoke config.status here -- let + compiler-level stuff handle all that. + + * err.c [MISSING_FILE_ELEMS]: Declare malloc in this case + too, so it doesn't end up as an integer. + +Sat Feb 1 02:43:48 1997 Craig Burley + + * libF77/Makefile.in: More fixup for $(F90BIT) -- wasn't + in list for ar command, and it wasn't correctly listed + in the list of things depending on f2c.h. + + * f2c.h.in: Fix up #error directive. + +1997-01-31 Dave Love + + * libF77/Makefile.in ($(lib)): Add $(F90BIT); shouldn't exclude + stuff f2c needs so we can share the library. + +Sat Jan 18 19:39:03 1997 Craig Burley + + * configure.in: No longer define ALWAYS_FLUSH, the + resulting performance is too low. + +Wed Dec 18 12:06:02 1996 Craig Burley + + Patch from Mumit Khan : + * libF77/s_paus.c: Add __CYGWIN32__ to list of macros + controlling how to pause. + +Sun Dec 1 21:25:27 1996 Craig Burley + + * configure: Regenerated using autoconf-2.12. + +Mon Nov 25 21:16:15 1996 Craig Burley + + * configure: Regenerated using autoconf-2.11. + +1996-11-19 Dave Love + + * libI77/backspace.c: Include sys/types.h for size_t. + +Wed Nov 6 14:17:27 1996 Craig Burley + + * f2c.h.in: Properly comment out the unsupported stuff so + we don't get build-time errors. + + * libF77/Version.c, libI77/Version.c: Restore macro definition + of version information. + + * libI77/Makefile.in (OBJ): Add ftell_.o to list of objects. + + * libI77/uio.c (do_ud): Fix up casts in PAD_UDread case just + like they were fixed in the other case. + +Thu Oct 31 22:27:45 1996 Craig Burley + + * libI77/ftell_.c (fseek_): Map incoming whence argument to + system's actual SEEK_CUR, SEEK_SET, or SEEK_END macro for + fseek(), and crash (gracefully) if the argument is invalid. + +1996-10-19 Dave Love + + * configure.in: Add check that we have the tools to cross-compile + if appropriate. + (NO_EOF_CHAR_CHECK,Skip_f2c_Undefs): Define. + + * libF77/Makefile.in (F90BIT): New routines from Netlib. + + * f2c.h.in: + Use more sanitary #error (indented for K&R compliance if necessary) if + f2c_i2 defined. + Sync with Netlib: Add `uninteger'. (Commented out) integer*8 stuff. + bit_{test,clear,set} macros. + +1996-10-19 Dave Love + + Update to Netlib version of 1996-09-26. + + * libI77/Version.c: Use , not "stdio.h". + * libF77/Version.c: Likewise. + +Wed Aug 28 13:25:29 1996 Dave Love + + * libI77/rsne.c (x_rsne): Use size_t instead of int. + + * libI77/endfile.c (copy): Use size_t in place of int. + +Wed Aug 28 13:22:20 1996 Dave Love + + * libI77/backspace.c (f_back): Cast fread arg to size_t. + +Tue Aug 27 19:11:30 1996 Dave Love + + * libI77/Version.c: Supply */ to avoid apparent nested comment. + +Tue Aug 20 09:21:43 1996 Dave Love + + * libF77/Makefile.in (ALL_CFLAGS): Fix missing ../ for include. + * libI77/Makefile.in (ALL_CFLAGS): Likewise. + +Sat Aug 17 13:00:47 1996 Dave Love + + * (libF77/qbitshft.c, libF77/qbitbits.c, libF77/lbitshft.c, + libF77/lbitbits.c): New file from Netlib. qbit... not currently + compiled. + +Sun Jul 7 18:06:33 1996 Dave Love + + * libF77/z_sqrt.c, libF77/z_sin.c, libF77/z_exp.c, libF77/z_log.c, + libF77/system_.c, libF77/z_cos.c, libF77/signal_.c, + libF77/s_stop.c, libF77/sig_die.c, libF77/s_paus.c, + libF77/s_rnge.c, libF77/s_cat.c, libF77/r_tan.c, libF77/r_tanh.c, + libF77/r_sinh.c, libF77/r_sqrt.c, libF77/r_sin.c, libF77/r_mod.c, + libF77/r_nint.c, libF77/r_lg10.c, libF77/r_log.c, libF77/r_exp.c, + libF77/r_int.c, libF77/r_cosh.c, libF77/r_atn2.c, libF77/r_cos.c, + libF77/r_asin.c, libF77/r_atan.c, libF77/r_acos.c, + libF77/pow_dd.c, libF77/pow_zz.c, libF77/main.c, libF77/i_dnnt.c, + libF77/i_nint.c, libF77/h_dnnt.c, libF77/h_nint.c, libF77/exit.c, + libF77/d_tan.c, libF77/d_tanh.c, libF77/d_sqrt.c, libF77/d_sin.c, + libF77/d_sinh.c, libF77/d_mod.c, libF77/d_nint.c, libF77/d_log.c, + libF77/d_int.c, libF77/d_lg10.c, libF77/d_cosh.c, libF77/d_exp.c, + libF77/d_atn2.c, libF77/d_cos.c, libF77/d_atan.c, libF77/d_acos.c, + libF77/d_asin.c, libF77/c_sqrt.c, libF77/cabs.c, libF77/c_sin.c, + libF77/c_exp.c, libF77/c_log.c, libF77/c_cos.c, libF77/F77_aloc.c, + libF77/abort_.c, libI77/xwsne.c, libI77/wref.c, libI77/util.c, + libI77/uio.c, libI77/rsne.c, libI77/rdfmt.c, libI77/rawio.h, + libI77/open.c, libI77/lread.c, libI77/inquire.c, libI77/fio.h, + libI77/err.c, libI77/endfile.c, libI77/close.c: + Use #include <...>, not #include "..." for mkdeps + +Sat Jul 6 21:39:21 1996 Dave Love + + * libI77/ftell_.c: Added from Netlib distribution. + +Sat Mar 30 20:57:24 1996 Dave Love + + * configure.in: Eliminate explicit use of + {RANLIB,AR}_FOR_TARGET. + * Makefile.in: Likewise. + * libF77/Makefile.in: Likewise. + * libI77/Makefile.in: Likewise. + * configure: Regenerated. + +Sat Mar 30 21:02:03 1996 Dave Love + + * Makefile.in: Eliminate explicit use of + {RANLIB,AR}_FOR_TARGET. + +Tue Mar 26 23:39:59 1996 Dave Love + + * Makefile.in: Remove hardwired RANLIB and RANLIB_TEST (unnoted + change). + +Mon Mar 25 21:04:56 1996 Craig Burley + + * Incorporate changes by Bell Labs to libf2c through 1996-03-23, + including changes to dmg and netlib email addresses. + +Tue Mar 19 13:10:02 1996 Craig Burley + + * Incorporate changes by AT&T/Bellcore to libf2c through 1996-03-19. + + * Makefile.in (rebuilt): New target. + + * lib[FI]77/Makefile.in: Use $AR_FOR_TARGET, not $AR. + +Tue Mar 19 12:53:19 1996 Dave Love + + * configure.in (ac_cpp): #include instead + of . + +Tue Mar 19 12:52:09 1996 Mumit Khan + + * configure.in (ac_cpp): For f2c integer type, + add -I$srcdir/../.. to make it work on mips-ultrix4.2. + +Sat Mar 9 17:37:15 1996 Craig Burley + + * libI77/Makefile.in (.c.o): Add -DAllow_TYQUAD, to enable + I/O support for INTEGER*8. + * f2c.h.in: Turn on longint type. + +Fri Dec 29 18:22:01 1995 Craig Burley + + * Makefile.in: Reorganize the *clean rules to more closely + parallel gcc's. + + * lib[FI]77/Makefile.in: Ignore error from $(AR) command, + in case just doing an install and installer has no write + access to library (this is a kludge fix -- perhaps install + targets should never try updating anything?). + +Sat Nov 18 19:37:22 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.17 released. + +Thu Nov 16 07:20:35 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Incorporate changes by AT&T/Bellcore to libf2c through 1995-11-15. + +Fri Sep 22 02:19:59 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * libI77/backspace.c, libI77/close.c, libI77/endfile.c, + libI77/fio.h, libI77/inquire.c, libI77/rawio.h, + libF77/s_paus.c: Not an MSDOS system if GO32 + is defined, in the sense that the run-time environment + is thus more UNIX-like. + +Wed Sep 20 02:24:51 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * libF77/Makefile.in, libI77/Makefile.in: Comment out `ld -r -x' + and `mv' line pairs, since `-x' isn't supported on systems + such as Solaris, and these lines don't seem to do anything + useful after all. + +Wed Aug 30 15:58:35 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Version 0.5.16 released. + + * Incorporate changes by AT&T/Bellcore to libf2c through 950829. + +Mon Aug 28 12:50:34 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * libF77/Makefile.in, libI77/Makefile.in ($(lib)): Force ar'ing + and ranlib'ing of libf2c.a, else after rm'ing libf2c.a and + doing a make, only libI77 or libF77 would be added to + the newly created archive. + Also, instead of `$?' list all targets explicitly so all + objects are updated in libf2c.a even if only one actually + needs recompiling, for similar reason -- we can't easily tell + if a given object is really up-to-date in libf2c.a, or even + present there. + +Sun Aug 27 14:54:24 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * libF77/Makefile.in, libI77/Makefile.in: Fix spacing so + initial tabs are present in all appropriate places. + Move identical $(AR) commands in if then/else clauses + to single command preceding if. + (.c.o, Version[FI].o): Use $@ instead of $* because AIX (RS/6000) + says $@ means source, not object, basename, and $@ seems to work + everywhere. + +Wed Aug 23 15:44:25 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * libF77/system_.c (system_): Declare as returning `ftnint', + consistent with signal_, instead of defaulting to `int'. + Hope dmg@research.att.com agrees, else probably will + change to whatever he determines is correct (and change + g77 accordingly). + +Thu Aug 17 08:46:17 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * libI77/rsne.c (s_rsne): Call f_init if not already done. + +Thu Aug 17 04:35:28 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Incorporate changes by Bellcore to libf2c through 950817. + And this text is for EMACS: (foo at bar). + +Wed Aug 16 17:33:06 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * libF77/Makefile.in, libI77/Makefile.in (CFLAGS): Put -g1 + after configured CFLAGS but before GCC_CFLAGS, so by default + the libraries are built with minimal debugging information. + +Fri Jul 28 10:30:15 1995 Dave Love + + * libI77/open.c (f_open): Call f_init if not already done. + +Sat Jul 1 19:31:56 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * libF77/system_.c (system_): Make buff one byte bigger so + following byte doesn't get overwritten by call with large + string. + +Tue Jun 27 23:28:16 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Incorporate changes by Bellcore to libf2c through 950613. + + * libF77/Version.c (__G77_LIBF77_VERSION__): Add this string + to track g77 mods to libf2c. + + * libI77/Version.c (__G77_LIBI77_VERSION__): Add this string + to track g77 mods to libf2c. + + * libI77/rawio.h: #include only conditionally, + using macro intended for that purpose. + +Fri May 19 11:20:00 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * configure.in: Incorporate change made by d.love, + + * configure: Regenerated. + +Wed Apr 26 21:08:57 BST 1995 Dave Love + + * configure.in: Fix quoting problem in atexit check. + + * configure: Regenerated (with current autoconf). + +Wed Mar 15 12:49:58 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Incorporate changes by Bellcore to libf2c through 950315. + +Sun Mar 5 18:54:29 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * README: Tell people not to read lib[fi]77/README. + +Wed Feb 15 14:30:58 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * configure.in: Update copyright notice at top of file. + + * f2c.h.in (f2c_i2): Make sure defining this crashes compilations. + + * libI77/Makefile.in (F2C_H): Fix typo in definition of this + symbol (was FF2C_H=...). + +Sun Feb 12 13:39:36 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * README: Remove some obsolete items. + Add date. + + * TODO: Add date. + +Sat Feb 11 22:07:54 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Makefile.in (libf77, libi77): Add rules to .PHONY list. + + * f2c.h.in (flag): Make same type as friends. + + * libF77/Makefile.in (libf77): Rename to $(lib), remove from + .PHONY list. Fix some typos. + + * libI77/Makefile.in (libi77): Rename to $(lib), remove from + .PHONY list. Fix some typos. + +Thu Feb 2 12:22:41 1995 Craig Burley (burley@gnu.ai.mit.edu) + + * Makefile.in (libF77/Makefile): Fix typos in this rule's name + and dependencies. + + * libF77/Makefile.in (libf77): Add rule to .PHONY list. + + * libI77/Makefile.in (libi77): Add rule to .PHONY list. diff --git a/gcc/f/runtime/Makefile.in b/gcc/f/runtime/Makefile.in new file mode 100644 index 000000000000..1a20476bd263 --- /dev/null +++ b/gcc/f/runtime/Makefile.in @@ -0,0 +1,251 @@ +# Makefile for GNU F77 compiler runtime. +# Copyright (C) 1995-1997 Free Software Foundation, Inc. +# Contributed by Dave Love (d.love@dl.ac.uk). +# +#This file is part of GNU Fortran. +# +#GNU Fortran is free software; you can redistribute it and/or modify +#it under the terms of the GNU General Public License as published by +#the Free Software Foundation; either version 2, or (at your option) +#any later version. +# +#GNU Fortran is distributed in the hope that it will be useful, +#but WITHOUT ANY WARRANTY; without even the implied warranty of +#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +#GNU General Public License for more details. +# +#You should have received a copy of the GNU General Public License +#along with GNU Fortran; see the file COPYING. If not, write to +#the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +#02111-1307, USA. + +#### Start of system configuration section. #### + +# $(srcdir) must be set to the g77 runtime source directory +# (g77/f/runtime/). + +srcdir = @srcdir@ +VPATH = @srcdir@ + +top_srcdir = @top_srcdir@ + +INSTALL = @INSTALL@ # installs aren't actually done from here +INSTALL_PROGRAM = @INSTALL_PROGRAM@ +INSTALL_DATA = @INSTALL_DATA@ +RANLIB = @RANLIB@ +RANLIB_TEST = @RANLIB_TEST@ + +CFLAGS = @CFLAGS@ +CPPFLAGS = @CPPFLAGS@ @DEFS@ +LDFLAGS = @LDFLAGS@ +LIBS = @LIBS@ +CGFLAGS = -g0 + +GCC_FOR_TARGET = @CC@ +CC = $(GCC_FOR_TARGET) + +CROSS = @CROSS@ + +objext = .o + +transform=@program_transform_name@ + +prefix = @prefix@ +exec_prefix = @exec_prefix@ + +AR = ar +AR_FLAGS = rc + +# Directory in which to install scripts. +bindir = $(exec_prefix)/bin + +# Directory in which to install library files. +libdir = $(prefix)/lib + +# Directory in which to install documentation info files. +infodir = $(prefix)/info + +#### End of system configuration section. #### + +SHELL = /bin/sh + +lib = ../../libf2c.a + +SUBDIRS = libI77 libF77 libU77 + +MISC = libF77/F77_aloc.o libF77/VersionF.o libF77/main.o libF77/s_rnge.o \ + libF77/abort_.o libF77/getarg_.o libF77/iargc_.o libF77/getenv_.o \ + libF77/signal_.o libF77/s_stop.o libF77/s_paus.o libF77/system_.o \ + libF77/cabs.o libF77/derf_.o libF77/derfc_.o libF77/erf_.o \ + libF77/erfc_.o libF77/sig_die.o libF77/exit_.o +POW = libF77/pow_ci.o libF77/pow_dd.o libF77/pow_di.o libF77/pow_hh.o \ + libF77/pow_ii.o libF77/pow_ri.o libF77/pow_zi.o libF77/pow_zz.o \ + libF77/pow_qq.o +CX = libF77/c_abs.o libF77/c_cos.o libF77/c_div.o libF77/c_exp.o \ + libF77/c_log.o libF77/c_sin.o libF77/c_sqrt.o +DCX = libF77/z_abs.o libF77/z_cos.o libF77/z_div.o libF77/z_exp.o \ + libF77/z_log.o libF77/z_sin.o libF77/z_sqrt.o +REAL = libF77/r_abs.o libF77/r_acos.o libF77/r_asin.o libF77/r_atan.o \ + libF77/r_atn2.o libF77/r_cnjg.o libF77/r_cos.o libF77/r_cosh.o \ + libF77/r_dim.o libF77/r_exp.o libF77/r_imag.o libF77/r_int.o \ + libF77/r_lg10.o libF77/r_log.o libF77/r_mod.o libF77/r_nint.o \ + libF77/r_sign.o libF77/r_sin.o libF77/r_sinh.o libF77/r_sqrt.o \ + libF77/r_tan.o libF77/r_tanh.o +DBL = libF77/d_abs.o libF77/d_acos.o libF77/d_asin.o libF77/d_atan.o \ + libF77/d_atn2.o libF77/d_cnjg.o libF77/d_cos.o libF77/d_cosh.o \ + libF77/d_dim.o libF77/d_exp.o libF77/d_imag.o libF77/d_int.o \ + libF77/d_lg10.o libF77/d_log.o libF77/d_mod.o libF77/d_nint.o \ + libF77/d_prod.o libF77/d_sign.o libF77/d_sin.o libF77/d_sinh.o \ + libF77/d_sqrt.o libF77/d_tan.o libF77/d_tanh.o +INT = libF77/i_abs.o libF77/i_dim.o libF77/i_dnnt.o libF77/i_indx.o \ + libF77/i_len.o libF77/i_mod.o libF77/i_nint.o libF77/i_sign.o +HALF = libF77/h_abs.o libF77/h_dim.o libF77/h_dnnt.o libF77/h_indx.o \ + libF77/h_len.o libF77/h_mod.o libF77/h_nint.o libF77/h_sign.o +CMP = libF77/l_ge.o libF77/l_gt.o libF77/l_le.o libF77/l_lt.o \ + libF77/hl_ge.o libF77/hl_gt.o libF77/hl_le.o libF77/hl_lt.o +EFL = libF77/ef1asc_.o libF77/ef1cmc_.o +CHAR = libF77/s_cat.o libF77/s_cmp.o libF77/s_copy.o +F90BIT = libF77/lbitbits.o libF77/lbitshft.o libF77/qbitbits.o \ + libF77/qbitshft.o +FOBJ = $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) $(HALF) $(CMP) \ + $(EFL) $(CHAR) $(F90BIT) + +IOBJ = libI77/VersionI.o libI77/backspace.o libI77/close.o libI77/dfe.o \ + libI77/dolio.o libI77/due.o libI77/endfile.o libI77/err.o \ + libI77/fmt.o libI77/fmtlib.o libI77/iio.o libI77/ilnw.o \ + libI77/inquire.o libI77/lread.o libI77/lwrite.o libI77/open.o \ + libI77/rdfmt.o libI77/rewind.o libI77/rsfe.o libI77/rsli.o \ + libI77/rsne.o libI77/sfe.o libI77/sue.o libI77/typesize.o \ + libI77/uio.o libI77/util.o libI77/wref.o libI77/wrtfmt.o \ + libI77/wsfe.o libI77/wsle.o libI77/wsne.o libI77/xwsne.o \ + libI77/ftell_.o + +UOBJ = libU77/VersionU.o libU77/gerror_.o libU77/perror_.o libU77/ierrno_.o \ + libU77/itime_.o libU77/time_.o libU77/unlink_.o libU77/fnum_.o \ + libU77/getpid_.o libU77/getuid_.o libU77/getgid_.o libU77/kill_.o \ + libU77/rand_.o libU77/srand_.o libU77/irand_.o libU77/sleep_.o \ + libU77/idate_.o libU77/ctime_.o libU77/etime_.o libU77/dtime_.o \ + libU77/isatty_.o libU77/ltime_.o libU77/fstat_.o libU77/stat_.o \ + libU77/lstat_.o libU77/access_.o libU77/link_.o libU77/getlog_.o \ + libU77/ttynam_.o libU77/getcwd_.o libU77/vxttime_.o \ + libU77/vxtidate_.o libU77/gmtime_.o libU77/fdate_.o libU77/secnds_.o \ + libU77/bes.o libU77/dbes.o libU77/chdir_.o libU77/chmod_.o \ + libU77/lnblnk_.o libU77/hostnm_.o libU77/rename_.o libU77/fgetc_.o \ + libU77/fputc_.o libU77/umask_.o libU77/system_clock_.o libU77/date_.o \ + libU77/second_.o libU77/flush1_.o libU77/alarm_.o + +F2CEXT = abort derf derfc ef1asc ef1cmc erf erfc exit getarg getenv iargc \ + signal system flush ftell fseek access besj0 besj1 besjn besy0 besy1 \ + besyn chdir chmod ctime date dbesj0 dbesj1 dbesjn dbesy0 dbesy1 dbesyn \ + dtime etime fdate fgetc fget flush1 fnum fputc fput fstat gerror \ + getcwd getgid getlog getpid getuid gmtime hostnm idate ierrno irand \ + isatty itime kill link lnblnk lstat ltime mclock perror rand rename \ + secnds second sleep srand stat symlnk sclock time ttynam umask unlink \ + vxtidt vxttim alarm + +# flags_to_pass to recursive makes & configure (hence the quoting style) +FLAGS_TO_PASS = \ + CROSS="$(CROSS)" \ + AR_FLAGS="$(AR_FLAGS)" \ + AR="$(AR)" \ + GCCFLAGS="$(GCCFLAGS)" \ + GCC_FOR_TARGET="$(GCC_FOR_TARGET)" \ + CC="$(GCC_FOR_TARGET)" \ + LDFLAGS="$(LDFLAGS)" \ + RANLIB="$(RANLIB)" \ + RANLIB_TEST="$(RANLIB_TEST)" \ + SHELL="$(SHELL)" + +CROSS_FLAGS_TO_PASS = \ + CROSS="$(CROSS)" \ + AR_FLAGS="$(AR_FLAGS)" \ + AR="$(AR)" \ + GCCFLAGS="$(GCCFLAGS)" \ + GCC_FOR_TARGET="$(GCC_FOR_TARGET)" \ + CC="$(GCC_FOR_TARGET)" \ + LDFLAGS="$(LDFLAGS)" \ + RANLIB="$(RANLIB)" \ + RANLIB_TEST="$(RANLIB_TEST)" \ + SHELL="$(SHELL)" + +all: ../../include/f2c.h libi77 libf77 libu77 $(lib) + +$(lib): stamp-lib ; @true +stamp-lib: $(FOBJ) $(IOBJ) $(UOBJ) + rm -f stamp-lib + $(AR) $(AR_FLAGS) $(lib) $? + for name in $(F2CEXT); \ + do \ + echo $${name}; \ + $(GCC_FOR_TARGET) -c -I. -I$(srcdir) -I../../include $(CPPFLAGS) $(CFLAGS) $(CGFLAGS) \ + -DL$${name} $(srcdir)/f2cext.c; \ + if [ $$? -eq 0 ] ; then true; else exit 1; fi; \ + mv f2cext$(objext) L$${name}$(objext); \ + $(AR) $(AR_FLAGS) $(lib) L$${name}$(objext); \ + rm -f L$${name}$(objext); \ + done + if $(RANLIB_TEST); then $(RANLIB) $(lib); \ + else true; fi + touch stamp-lib + +libi77: libI77/Makefile + if test "$(CROSS)"; then \ + cd libI77; $(MAKE) -f Makefile $(CROSS_FLAGS_TO_PASS) all ; \ + else \ + cd libI77; $(MAKE) -f Makefile $(FLAGS_TO_PASS) all ; \ + fi + +libf77: libF77/Makefile + if test "$(CROSS)"; then \ + cd libF77; $(MAKE) -f Makefile $(CROSS_FLAGS_TO_PASS) all ; \ + else \ + cd libF77; $(MAKE) -f Makefile $(FLAGS_TO_PASS) all ; \ + fi + +libu77: libU77/Makefile + if test "$(CROSS)"; then \ + cd libU77; $(MAKE) -f Makefile $(CROSS_FLAGS_TO_PASS) all ; \ + else \ + cd libU77; $(MAKE) -f Makefile $(FLAGS_TO_PASS) all ; \ + fi + +${srcdir}/configure: ${srcdir}/configure.in + rm -f config.cache && cd ${srcdir} && autoconf && rm -f config.cache +${srcdir}/libU77/configure: ${srcdir}/libU77/configure.in + rm -f libU77/config.cache && cd ${srcdir}/libU77 && autoconf && rm -f config.cache +#../include/f2c.h libI77/Makefile libF77/Makefile libU77/Makefile Makefile: ${srcdir}/Makefile.in \ +# config.status libU77/config.status +# $(FLAGS_TO_PASS) CONFIG_SITE=/dev/null $(SHELL) config.status +# cd libU77; $(FLAGS_TO_PASS) CONFIG_SITE=/dev/null $(SHELL) config.status + +# Extra dependencies for the targets above: +libI77/Makefile: $(srcdir)/libI77/Makefile.in +libF77/Makefile: $(srcdir)/libF77/Makefile.in +libU77/Makefile: $(srcdir)/libU77/Makefile.in +../../include/f2c.h: $(srcdir)/f2c.h.in + +#config.status: ${srcdir}/configure +# $(FLAGS_TO_PASS) CONFIG_SITE=/dev/null $(SHELL) config.status --recheck +#libU77/config.status: ${srcdir}/libU77/configure +# cd libU77; $(FLAGS_TO_PASS) CONFIG_SITE=/dev/null $(SHELL) config.status --recheck + +mostlyclean: + for i in libI77 libF77 libU77; do cd $$i; $(MAKE) -f Makefile mostlyclean; cd ..; done + +clean: + -rm -f config.log config.cache + for i in libI77 libF77 libU77; do cd $$i; $(MAKE) -f Makefile clean; cd ..; done + +distclean: clean + -rm -f Makefile lib?77/Makefile config.status libU77/config.status ../../include/f2c.h + +maintainer-clean: distclean + -rm -f $(srcdir)/configure $(srcdir)/libU77/configure + +uninstall: + rm ../../include/f2c.h + +rebuilt: ${srcdir}/configure ${srcdir}/libU77/configure + +.PHONY: libf77 libi77 libu77 rebuilt mostlyclean clean distclean maintainer-clean \ + uninstall all diff --git a/gcc/f/runtime/README b/gcc/f/runtime/README new file mode 100644 index 000000000000..9419af77189e --- /dev/null +++ b/gcc/f/runtime/README @@ -0,0 +1,46 @@ +970811 + +This directory contains the f2c library packaged for use with g77 to configure +and build automatically (in principle!) as part of the top-level configure and +make steps. This depends on the makefile and configure fragments in ../f. + +Some small changes have been made to the f2c distributions of lib[FI]77 which +come from and are maintained (excellently) by +David M. Gay . See the Notice files for copyright +information. I'll try to get the changes rolled into the f2c distribution. + +Files that come directly from netlib are either maintained in the +gcc/f/runtime/ directory under their original names or, if they +are not pertinent for g77's version of libf2c, under their original +names with `.netlib' appended. For example, gcc/f/runtime/permissions.netlib +is a copy of f2c's top-level`permissions' file in the netlib distribution. +In this case, it applies only to the relevant portions of the libF77/ and +libI77/ directories; it does not apply to the libU77/ directory, which is +distributed under different licensing arrangements. Similarly, +the `makefile.netlib' files in libF77/ and libI77/ are copies of +the respective `makefile' files in the netlib distribution, but +are not used when building g77's version of libf2c. + +The `README.netlib' files in libF77/ and libI77/ thus might be +interesting, but should not be taken as guidelines for how to +configure and build libf2c in g77's distribution. + +The packaging for auto-configuration was done by Dave Love . +Minor changes have been made by James Craig Burley , +who probably broke things Dave had working. :-) + +Among the user-visible changes (choices) g77 makes in its +version of libf2c: + +- f2c.h configured to default to padding unformatted direct reads + (#define Pad_UDread), because that's the behavior most users + expect. + +- f2c.h configured to default to outputting leading zeros before + decimal points in formatted and list-directed output, to be compatible + with many other compilers (#define WANT_LEAD_0). Either way is + standard-conforming, however, and you should try to avoid writing + code that assumes one format or another. + +- dtime_() and etime_() are from Dave Love's libU77, not from + netlib's libF77. diff --git a/gcc/f/runtime/TODO b/gcc/f/runtime/TODO new file mode 100644 index 000000000000..a44d1ed7f231 --- /dev/null +++ b/gcc/f/runtime/TODO @@ -0,0 +1,17 @@ +970811 + +TODO list for the g77 library + +* `Makefile.in's should be brought up to standard; I'm not sure they + have a complete set of targets at present. + +* Investigate building shared libraries on systems we know about + (probably in 0.5.22, using libtool-1.0 from the FSF, which looks + quite useful). + +* Test cases. + +* Allow the library to be stripped to save space. + +* An interface to IEEE maths functions from libc where this makes + sense. diff --git a/gcc/f/runtime/changes.netlib b/gcc/f/runtime/changes.netlib new file mode 100644 index 000000000000..0edfba3a8549 --- /dev/null +++ b/gcc/f/runtime/changes.netlib @@ -0,0 +1,2836 @@ +31 Aug. 1989: + 1. A(min(i,j)) now is translated correctly (where A is an array). + 2. 7 and 8 character variable names are allowed (but elicit a + complaint under -ext). + 3. LOGICAL*1 is treated as LOGICAL, with just one error message + per LOGICAL*1 statement (rather than one per variable declared + in that statement). [Note that LOGICAL*1 is not in Fortran 77.] + Like f77, f2c now allows the format in a read or write statement + to be an integer array. + +5 Sept. 1989: + Fixed botch in argument passing of substrings of equivalenced +variables. + +15 Sept. 1989: + Warn about incorrect code generated when a character-valued +function is not declared external and is passed as a parameter +(in violation of the Fortran 77 standard) before it is invoked. +Example: + + subroutine foo(a,b) + character*10 a,b + call goo(a,b) + b = a(3) + end + +18 Sept. 1989: + Complain about overlapping initializations. + +20 Sept. 1989: + Warn about names declared EXTERNAL but never referenced; +include such names as externs in the generated C (even +though most C compilers will discard them). + +24 Sept. 1989: + New option -w8 to suppress complaint when COMMON or EQUIVALENCE +forces word alignment of a double. + Under -A (for ANSI C), ensure that floating constants (terminated +by 'f') contain either a decimal point or an exponent field. + Repair bugs sometimes encountered with CHAR and ICHAR intrinsic +functions. + Restore f77's optimizations for copying and comparing character +strings of length 1. + Always assume floating-point valued routines in libF77 return +doubles, even under -R. + Repair occasional omission of arguments in routines having multiple +entry points. + Repair bugs in computing offsets of character strings involved +in EQUIVALENCE. + Don't omit structure qualification when COMMON variables are used +as FORMATs or internal files. + +2 Oct. 1989: + Warn about variables that appear only in data stmts; don't emit them. + Fix bugs in character DATA for noncharacter variables +involved in EQUIVALENCE. + Treat noncharacter variables initialized (at least partly) with +character data as though they were equivalenced -- put out a struct +and #define the variables. This eliminates the hideous and nonportable +numeric values that were used to initialize such variables. + Treat IMPLICIT NONE as IMPLICIT UNDEFINED(A-Z) . + Quit when given invalid options. + +8 Oct. 1989: + Modified naming scheme for generated intermediate variables; +more are recycled, fewer distinct ones used. + New option -W nn specifies nn characters/word for Hollerith +data initializing non-character variables. + Bug fix: x(i:min(i+10,j)) used to elicit "Can't handle opcode 31 yet". + Integer expressions of the form (i+const1) - (i+const2), where +i is a scalar integer variable, are now simplified to (const1-const2); +this leads to simpler translation of some substring expressions. + Initialize uninitialized portions of character string arrays to 0 +rather than to blanks. + +9 Oct. 1989: + New option -c to insert comments showing original Fortran source. + New option -g to insert line numbers of original Fortran source. + +10 Oct. 1989: + ! recognized as in-line comment delimiter (a la Fortran 88). + +24 Oct. 1989: + New options to ease coping with systems that want the structs +that result from COMMON blocks to be defined just once: + -E causes uninitialized COMMON blocks to be declared Extern; +if Extern is undefined, f2c.h #defines it to be extern. + -ec causes a separate .c file to be emitted for each +uninitialized COMMON block: COMMON /ABC/ yields abc_com.c; +thus one can compile *_com.c into a library to ensure +precisely one definition. + -e1c is similar to -ec, except that everything goes into +one file, along with comments that give a sed script for +splitting the file into the pieces that -ec would give. +This is for use with netlib's "execute f2c" service (for which +-ec is coerced into -e1c, and the sed script will put everything +but the COMMON definitions into f2c_out.c ). + +28 Oct. 1989: + Convert "i = i op ..." into "i op= ...;" even when i is a +dummy argument. + +13 Nov. 1989: + Name integer constants (passed as arguments) c__... rather +than c_... so + common /c/stuff + call foo(1) + ... +is translated correctly. + +19 Nov. 1989: + Floating-point constants are now kept as strings unless they +are involved in constant expressions that get simplified. The +floating-point constants kept as strings can have arbitrarily +many significant figures and a very large exponent field (as +large as long int allows on the machine on which f2c runs). +Thus, for example, the body of + + subroutine zot(x) + double precision x(6), pi + parameter (pi=3.1415926535897932384626433832795028841972) + x(1) = pi + x(2) = pi+1 + x(3) = 9287349823749272.7429874923740978492734D-298374 + x(4) = .89 + x(5) = 4.0005 + x(6) = 10D7 + end + +now gets translated into + + x[1] = 3.1415926535897932384626433832795028841972; + x[2] = 4.1415926535897931; + x[3] = 9.2873498237492727429874923740978492734e-298359; + x[4] = (float).89; + x[5] = (float)4.0005; + x[6] = 1e8; + +rather than the former + + x[1] = 3.1415926535897931; + x[2] = 4.1415926535897931; + x[3] = 0.; + x[4] = (float)0.89000000000000003; + x[5] = (float)4.0004999999999997; + x[6] = 100000000.; + + Recognition of f77 machine-constant intrinsics deleted, i.e., +epbase, epprec, epemin, epemax, eptiny, ephuge, epmrsp. + +22 Nov. 1989: + Workarounds for glitches on some Sun systems... + libf77: libF77/makefile modified to point out possible need +to compile libF77/main.c with -Donexit=on_exit . + libi77: libI77/wref.c (and libI77/README) modified so non-ANSI +systems can compile with USE_STRLEN defined, which will cause + sprintf(b = buf, "%#.*f", d, x); + n = strlen(b) + d1; +rather than + n = sprintf(b = buf, "%#.*f", d, x) + d1; +to be compiled. + +26 Nov. 1989: + Longer names are now accepted (up to 50 characters); names may +contain underscores (in which case they will have two underscores +appended, to avoid clashes with library names). + +28 Nov. 1989: + libi77 updated: + 1. Allow 3 (or, on Crays, 4) digit exponents under format Ew.d . + 2. Try to get things right on machines where ints have 16 bits. + +29 Nov. 1989: + Supplied missing semicolon in parameterless subroutines that +have multiple entry points (all of them parameterless). + +30 Nov. 1989: + libf77 and libi77 revised to use types from f2c.h. + f2c now types floating-point valued C library routines as "double" +rather than "doublereal" (for use with nonstandard C compilers for +which "double" is IEEE double extended). + +1 Dec. 1989: + f2c.h updated to eliminate #defines rendered unnecessary (and, +indeed, dangerous) by change of 26 Nov. to long names possibly +containing underscores. + libi77 further revised: yesterday's change omitted two tweaks to fmt.h +(tweaks which only matter if float and real or double and doublereal are +different types). + +2 Dec. 1989: + Better error message (than "bad tag") for NAMELIST, which no longer +inhibits C output. + +4 Dec. 1989: + Allow capital letters in hex constants (f77 extension; e.g., +x'a012BCd', X'A012BCD' and x'a012bcd' are all treated as the integer +167848909). + libi77 further revised: lio.c lio.h lread.c wref.c wrtfmt.c tweaked +again to allow float and real or double and doublereal to be different. + +6 Dec. 1989: + Revised f2c.h -- required for the following... + Simpler looking translations for abs, min, max, using #defines in +revised f2c.h . + libi77: more corrections to types; additions for NAMELIST. + Corrected casts in some I/O calls. + Translation of NAMELIST; libi77 must still be revised. Currently +libi77 gives you a run-time error message if you attempt NAMELIST I/O. + +7 Dec. 1989: + Fixed bug that prevented local integer variables that appear in DATA +stmts from being ASSIGNed statement labels. + Fillers (for DATA statements initializing EQUIVALENCEd variables and +variables in COMMON) typed integer rather than doublereal (for slightly +more portability, e.g. to Crays). + libi77: missing return values supplied in a few places; some tests +reordered for better working on the Cray. + libf77: better accuracy for complex divide, complex square root, +real mod function (casts to double; double temporaries). + +9 Dec. 1989: + Fixed bug that caused needless (albeit harmless) empty lines to be +inserted in the C output when a comment line contained trailing blanks. + Further tweak to type of fillers: allow doublereal fillers if the +struct has doublereal data. + +11 Dec. 1989: + Alteration of rule for producing external (C) names from names that +contain underscores. Now the external name is always obtained by +appending a pair of underscores. + +12 Dec. 1989: + C production inhibited after most errors. + +15 Dec. 1989: + Fixed bug in headers for subroutines having two or more character +strings arguments: the length arguments were reversed. + +19 Dec. 1989: + f2c.h libf77 libi77: adjusted so #undefs in f2c.h should not foil +compilation of libF77 and libI77. + libf77: getenv_ adjusted to work with unsorted environments. + libi77: the iostat= specifier should now work right with internal I/O. + +20 Dec. 1989: + f2c bugs fixed: In the absence of an err= specifier, the iostat= +specifier was generally set wrong. Character strings containing +explicit nulls (\0) were truncated at the first null. + Unlabeled DO loops recognized; must be terminated by ENDDO. +(Don't ask for CYCLE, EXIT, named DO loops, or DO WHILE.) + +29 Dec. 1989: + Nested unlabeled DO loops now handled properly; new warning for +extraneous text at end of FORMAT. + +30 Dec. 1989: + Fixed bug in translating dble(real(...)), dble(sngl(...)), and +dble(float(...)), where ... is either of type double complex or +is an expression requiring assignment to intermediate variables (e.g., +dble(real(foo(x+1))), where foo is a function and x is a variable). +Regard nonblank label fields on continuation lines as an error. + +3 Jan. 1990: + New option -C++ yields output that should be understood +by C++ compilers. + +6 Jan. 1989: + -a now excludes variables that appear in a namelist from those +that it makes automatic. (As before, it also excludes variables +that appear in a common, data, equivalence, or save statement.) + The syntactically correct Fortran + read(*,i) x + end +now yields syntactically correct C (even though both the Fortran +and C are buggy -- no FORMAT has not been ASSIGNed to i). + +7 Jan. 1990: + libi77: routines supporting NAMELIST added. Surrounding quotes +made optional when no ambiguity arises in a list or namelist READ +of a character-string value. + +9 Jan. 1990: + f2c.src made available. + +16 Jan. 1990: + New options -P to produce ANSI C or C++ prototypes for procedures +defined. Change to -A and -C++: f2c tries to infer prototypes for +invoked procedures unless the new -!P option is given. New warning +messages for inconsistent calling sequences among procedures within +a single file. Most of f2c/src is affected. + f2c.h: typedefs for procedure arguments added; netlib's f2c service +will insert appropriate typedefs for use with older versions of f2c.h. + +17 Jan. 1990: + f2c/src: defs.h exec.c format.c proc.c putpcc.c version.c xsum0.out +updated. Castargs and protofile made extern in defs.h; exec.c +modified so superfluous else clauses are diagnosed; unused variables +omitted from declarations in format.c proc.c putpcc.c . + +21 Jan. 1990: + No C emitted for procedures declared external but not referenced. + f2c.h: more new types added for use with -P. + New feature: f2c accepts as arguments files ending in .p or .P; +such files are assumed to be prototype files, such as produced by +the -P option. All prototype files are read before any Fortran files +and apply globally to all Fortran files. Suitable prototypes help f2c +warn about calling-sequence errors and can tell f2c how to type +procedures declared external but not explicitly typed; the latter is +mainly of interest for users of the -A and -C++ options. (Prototype +arguments are not available to netlib's "execute f2c" service.) + New option -it tells f2c to try to infer types of untyped external +arguments from their use as parameters to prototyped or previously +defined procedures. + f2c/src: many minor cleanups; most modules changed. Individual +files in f2c/src are now in "bundle" format. The former f2c.1 is +now f2c.1t; "f2c.1t from f2c" and "f2c.1t from f2c/src" are now the +same, as are "f2c.1 from f2c" and "f2c.1 from f2c/src". People who +do not obtain a new copy of "all from f2c/src" should at least add + fclose(sortfp); +after the call on do_init_data(outfile, sortfp) in format_data.c . + +22 Jan. 1990: + Cleaner man page wording (thanks to Doug McIlroy). + -it now also applies to all untyped EXTERNAL procedures, not just +arguments. + +23 Jan. 01:34:00 EST 1990: + Bug fixes: under -A and -C++, incorrect C was generated for +subroutines having multiple entries but no arguments. + Under -A -P, subroutines of no arguments were given prototype +calling sequence () rather than (void). + Character-valued functions elicited erroneous warning messages +about inconsistent calling sequences when referenced by another +procedure in the same file. + f2c.1t: omit first appearance of libF77.a in FILES section; +load order of libraries is -lF77 -lI77, not vice versa (bug +introduced in yesterday's edits); define .F macro for those whose +-man lacks it. (For a while after yesterday's fixes were posted, +f2c.1t was out of date. Sorry!) + +23 Jan. 9:53:24 EST 1990: + Character substring expressions involving function calls having +character arguments (including the intrinsic len function) yielded +incorrect C. + Procedures defined after invocation (in the same file) with +conflicting argument types also got an erroneous message about +the wrong number of arguments. + +24 Jan. 11:44:00 EST 1990: + Bug fixes: -p omitted #undefs; COMMON block names containing +underscores had their C names incorrectly computed; a COMMON block +having the name of a previously defined procedure wreaked havoc; +if all arguments were .P files, f2c tried reading the second as a +Fortran file. + New feature: -P emits comments showing COMMON block lengths, so one +can get warnings of incompatible COMMON block lengths by having f2c +read .P (or .p) files. Now by running f2c twice, first with -P -!c +(or -P!c), then with *.P among the arguments, you can be warned of +inconsistent COMMON usage, and COMMON blocks having inconsistent +lengths will be given the maximum length. (The latter always did +happen within each input file; now -P lets you extend this behavior +across files.) + +26 Jan. 16:44:00 EST 1990: + Option -it made less aggressive: untyped external procedures that +are invoked are now typed by the rules of Fortran, rather than by +previous use of procedures to which they are passed as arguments +before being invoked. + Option -P now includes information about references, i.e., called +procedures, in the prototype files (in the form of special comments). +This allows iterative invocations of f2c to infer more about untyped +external names, particularly when multiple Fortran files are involved. + As usual, there are some obscure bug fixes: +1. Repair of erroneous warning messages about inconsistent number of +arguments that arose when a character dummy parameter was discovered +to be a function or when multiple entry points involved character +variables appearing in a previous entry point. +2. Repair of memory fault after error msg about "adjustable character +function". +3. Under -U, allow MAIN_ as a subroutine name (in the same file as a +main program). +4. Change for consistency: a known function invoked as a subroutine, +then as a function elicits a warning rather than an error. + +26 Jan. 22:32:00 EST 1990: + Fixed two bugs that resulted in incorrect C for substrings, within +the body of a character-valued function, of the function's name, when +those substrings were arguments to another function (even implicitly, +as in character-string assignment). + +28 Jan. 18:32:00 EST 1990: + libf77, libi77: checksum files added; "make check" looks for +transmission errors. NAMELIST read modified to allow $ rather than & +to precede a namelist name, to allow $ rather than / to terminate +input where the name of another variable would otherwise be expected, +and to regard all nonprinting ASCII characters <= ' ' as spaces. + +29 Jan. 02:11:00 EST 1990: + "fc from f2c" added. + -it option made the default; -!it turns it off. Type information is +now updated in a previously missed case. + -P option tweaked again; message about when rerunning f2c may change +prototypes or declarations made more accurate. + New option -Ps implies -P and returns exit status 4 if rerunning +f2c -P with prototype inputs might change prototypes or declarations. +Now you can execute a crude script like + + cat *.f >zap.F + rm -f zap.P + while :; do + f2c -Ps -!c zap.[FP] + case $? in 4) ;; *) break;; esac + done + +to get a file zap.P of the best prototypes f2c can determine for *.f . + +Jan. 29 07:30:21 EST 1990: + Forgot to check for error status when setting return code 4 under -Ps; +error status (1, 2, 3, or, for caught signal, 126) now takes precedence. + +Jan 29 14:17:00 EST 1990: + Incorrect handling of + open(n,'filename') +repaired -- now treated as + open(n,file='filename') +(and, under -ext, given an error message). + New optional source file memset.c for people whose systems don't +provide memset, memcmp, and memcpy; #include in mem.c +changed to #include "string.h" so BSD people can create a local +string.h that simply says #include . + +Jan 30 10:34:00 EST 1990: + Fix erroneous warning at end of definition of a procedure with +character arguments when the procedure had previously been called with +a numeric argument instead of a character argument. (There were two +warnings, the second one incorrectly complaining of a wrong number of +arguments.) + +Jan 30 16:29:41 EST 1990: + Fix case where -P and -Ps erroneously reported another iteration +necessary. (Only harm is the extra iteration.) + +Feb 3 01:40:00 EST 1990: + Supply semicolon occasionally omitted under -c . + Try to force correct alignment when numeric variables are initialized +with character data (a non-standard and non-portable practice). You +must use the -W option if your code has such data statements and is +meant to run on a machine with other than 4 characters/word; e.g., for +code meant to run on a Cray, you would specify -W8 . + Allow parentheses around expressions in output lists (in write and +print statements). + Rename source files so their names are <= 12 characters long +(so there's room to append .Z and still have <= 14 characters); +renamed files: formatdata.c niceprintf.c niceprintf.h safstrncpy.c . + f2c material made available by anonymous ftp from research.att.com +(look in dist/f2c ). + +Feb 3 03:49:00 EST 1990: + Repair memory fault that arose from use (in an assignment or +call) of a non-argument variable declared CHARACTER*(*). + +Feb 9 01:35:43 EST 1990: + Fix erroneous error msg about bad types in + subroutine foo(a,adim) + dimension a(adim) + integer adim + Fix improper passing of character args (and possible memory fault) +in the expression part of a computed goto. + Fix botched calling sequences in array references involving +functions having character args. + Fix memory fault caused by invocation of character-valued functions +of no arguments. + Fix botched calling sequence of a character*1-valued function +assigned to a character*1 variable. + Fix bug in error msg for inconsistent number of args in prototypes. + Allow generation of C output despite inconsistencies in prototypes, +but give exit code 8. + Simplify include logic (by removing some bogus logic); never +prepend "/usr/include/" to file names. + Minor cleanups (that should produce no visible change in f2c's +behavior) in intr.c parse.h main.c defs.h formatdata.c p1output.c . + +Feb 10 00:19:38 EST 1990: + Insert (integer) casts when floating-point expressions are used +as subscripts. + Make SAVE stmt (with no variable list) override -a . + Minor cleanups: change field to Field in struct Addrblock (for the +benefit of buggy C compilers); omit system("/bin/cp ...") in misc.c . + +Feb 13 00:39:00 EST 1990: + Error msg fix in gram.dcl: change "cannot make %s parameter" +to "cannot make into parameter". + +Feb 14 14:02:00 EST 1990: + Various cleanups (invisible on systems with 4-byte ints), thanks +to Dave Regan: vaxx.c eliminated; %d changed to %ld various places; +external names adjusted for the benefit of stupid systems (that ignore +case and recognize only 6 significant characters in external names); +buffer shortened in xsum.c (e.g. for MS-DOS); fopen modes distinguish +text and binary files; several unused functions eliminated; missing +arg supplied to an unlikely fatalstr invocation. + +Thu Feb 15 19:15:53 EST 1990: + More cleanups (invisible on systems with 4 byte ints); casts inserted +so most complaints from cyntax(1) and lint(1) go away; a few (int) +versus (long) casts corrected. + +Fri Feb 16 19:55:00 EST 1990: + Recognize and translate unnamed Fortran 8x do while statements. + Fix bug that occasionally caused improper breaking of character +strings. + New error message for attempts to provide DATA in a type-declaration +statement. + +Sat Feb 17 11:43:00 EST 1990: + Fix infinite loop clf -> Fatal -> done -> clf after I/O error. + Change "if (addrp->vclass = CLPROC)" to "if (addrp->vclass == CLPROC)" +in p1_addr (in p1output.c); this was probably harmless. + Move a misplaced } in lex.c (which slowed initkey()). + Thanks to Gary Word for pointing these things out. + +Sun Feb 18 18:07:00 EST 1990: + Detect overlapping initializations of arrays and scalar variables +in previously missed cases. + Treat logical*2 as logical (after issuing a warning). + Don't pass string literals to p1_comment(). + Correct a cast (introduced 16 Feb.) in gram.expr; this matters e.g. +on a Cray. + Attempt to isolate UNIX-specific things in sysdep.c (a new source +file). Unless sysdep.c is compiled with SYSTEM_SORT defined, the +intermediate files created for DATA statements are now sorted in-core +without invoking system(). + +Tue Feb 20 16:10:35 EST 1990: + Move definition of binread and binwrite from init.c to sysdep.c . + Recognize Fortran 8x tokens < <= == >= > <> as synonyms for +.LT. .LE. .EQ. .GE. .GT. .NE. + Minor cleanup in putpcc.c: fully remove simoffset(). + More discussion of system dependencies added to libI77/README. + +Tue Feb 20 21:44:07 EST 1990: + Minor cleanups for the benefit of EBCDIC machines -- try to remove +the assumption that 'a' through 'z' are contiguous. (Thanks again to +Gary Word.) Also, change log2 to log_2 (shouldn't be necessary). + +Wed Feb 21 06:24:56 EST 1990: + Fix botch in init.c introduced in previous change; only matters +to non-ASCII machines. + +Thu Feb 22 17:29:12 EST 1990: + Allow several entry points to mention the same array. Protect +parameter adjustments with if's (for the case that an array is not +an argument to all entrypoints). + Under -u, allow + subroutine foo(x,n) + real x(n) + integer n + Compute intermediate variables used to evaluate dimension expressions +at the right time. Example previously mistranslated: + subroutine foo(x,k,m,n) + real x(min(k,m,n)) + ... + write(*,*) x + Detect duplicate arguments. (The error msg points to the first +executable stmt -- not wonderful, but not worth fixing.) + Minor cleanup of min/max computation (sometimes slightly simpler). + +Sun Feb 25 09:39:01 EST 1990: + Minor tweak to multiple entry points: protect parameter adjustments +with if's only for (array) args that do not appear in all entry points. + Minor tweaks to format.c and io.c (invisible unless your compiler +complained at the duplicate #defines of IOSUNIT and IOSFMT or at +comparisons of p1gets(...) with NULL). + +Sun Feb 25 18:40:10 EST 1990: + Fix bug introduced Feb. 22: if a subprogram contained DATA and the +first executable statement was labeled, then the label got lost. +(Just change INEXEC to INDATA in p1output.c; it occurs just once.) + +Mon Feb 26 17:45:10 EST 1990: + Fix bug in handling of " and ' in comments. + +Wed Mar 28 01:43:06 EST 1990: +libI77: + 1. Repair nasty I/O bug: opening two files and closing the first +(after possibly reading or writing it), then writing the second caused +the last buffer of the second to be lost. + 2. Formatted reads of logical values treated all letters other than +t or T as f (false). + libI77 files changed: err.c rdfmt.c Version.c + (Request "libi77 from f2c" -- you can't get these files individually.) + +f2c itself: + Repair nasty bug in translation of + ELSE IF (condition involving complicated abs, min, or max) +-- auxiliary statements were emitted at the wrong place. + Supply semicolon previously omitted from the translation of a label +(of a CONTINUE) immediately preceding an ELSE IF or an ELSE. This +bug made f2c produce invalid C. + Correct a memory fault that occurred (on some machines) when the +error message "adjustable dimension on non-argument" should be given. + Minor tweaks to remove some harmless warnings by overly chatty C +compilers. + Argument arays having constant dimensions but a variable lower bound +(e.g., x(n+1:n+3)) had a * omitted from scalar arguments involved in +the array offset computation. + +Wed Mar 28 18:47:59 EST 1990: +libf77: add exit(0) to end of main [return(0) encounters a Cray bug] + +Sun Apr 1 16:20:58 EDT 1990: + Avoid dereferencing null when processing equivalences after an error. + +Fri Apr 6 08:29:49 EDT 1990: + Calls involving alternate return specifiers omitted processing +needed for things like min, max, abs, and // (concatenation). + INTEGER*2 PARAMETERs were treated as INTEGER*4. + Convert some O(n^2) parsing to O(n). + +Tue Apr 10 20:07:02 EDT 1990: + When inconsistent calling sequences involve differing numbers of +arguments, report the first differing argument rather than the numbers +of arguments. + Fix bug under -a: formatted I/O in which either the unit or the +format was a local character variable sometimes resulted in invalid C +(a static struct initialized with an automatic component). + Improve error message for invalid flag after elided -. + Complain when literal table overflows, rather than infinitely +looping. (The complaint mentions the new and otherwise undocumented +-NL option for specifying a larger literal table.) + New option -h for forcing strings to word (or, with -hd, double-word) +boundaries where possible. + Repair a bug that could cause improper splitting of strings. + Fix bug (cast of c to doublereal) in + subroutine foo(c,r) + double complex c + double precision r + c = cmplx(r,real(c)) + end + New include file "sysdep.h" has some things from defs.h (and +elsewhere) that one may need to modify on some systems. + Some large arrays that were previously statically allocated are now +dynamically allocated when f2c starts running. + f2c/src files changed: + README cds.c defs.h f2c.1 f2c.1t format.c formatdata.c init.c + io.c lex.c main.c makefile mem.c misc.c names.c niceprintf.c + output.c parse_args.c pread.c put.c putpcc.c sysdep.h + version.c xsum0.out + +Wed Apr 11 18:27:12 EDT 1990: + Fix bug in argument consistency checking of character, complex, and +double complex valued functions. If the same source file contained a +definition of such a function with arguments not explicitly typed, +then subsequent references to the function might get erroneous +warnings of inconsistent calling sequences. + Tweaks to sysdep.h for partially ANSI systems. + New options -kr and -krd cause f2c to use temporary variables to +enforce Fortran evaluation-order rules with pernicious, old-style C +compilers that apply the associative law to floating-point operations. + +Sat Apr 14 15:50:15 EDT 1990: + libi77: libI77 adjusted to allow list-directed and namelist I/O +of internal files; bug in namelist I/O of logical and character arrays +fixed; list input of complex numbers adjusted to permit d or D to +denote the start of the exponent field of a component. + f2c itself: fix bug in handling complicated lower-bound +expressions for character substrings; e.g., min and max did not work +right, nor did function invocations involving character arguments. + Switch to octal notation, rather than hexadecimal, for nonprinting +characters in character and string constants. + Fix bug (when neither -A nor -C++ was specified) in typing of +external arguments of type complex, double complex, or character: + subroutine foo(c) + external c + complex c +now results in + /* Complex */ int (*c) (); +(as, indeed, it once did) rather than + complex (*c) (); + +Sat Apr 14 22:50:39 EDT 1990: + libI77/makefile: updated "make check" to omit lio.c + lib[FI]77/makefile: trivial change: define CC = cc, reference $(CC). + (Request, e.g., "libi77 from f2c" -- you can't ask for individual +files from lib[FI]77.) + +Wed Apr 18 00:56:37 EDT 1990: + Move declaration of atof() from defs.h to sysdep.h, where it is +now not declared if stdlib.h is included. (NeXT's stdlib.h has a +#define atof that otherwise wreaks havoc.) + Under -u, provide a more intelligible error message (than "bad tag") +for an attempt to define a function without specifying its type. + +Wed Apr 18 17:26:27 EDT 1990: + Recognize \v (vertical tab) in Hollerith as well as quoted strings; +add recognition of \r (carriage return). + New option -!bs turns off recognition of escapes in character strings +(\0, \\, \b, \f, \n, \r, \t, \v). + Move to sysdep.c initialization of some arrays whose initialization +assumed ASCII; #define Table_size in sysdep.h rather than using +hard-coded 256 in allocating arrays of size 1 << (bits/byte). + +Thu Apr 19 08:13:21 EDT 1990: + Warn when escapes would make Hollerith extend beyond statement end. + Omit max() definition from misc.c (should be invisible except on +systems that erroneously #define max in stdlib.h). + +Mon Apr 23 22:24:51 EDT 1990: + When producing default-style C (no -A or -C++), cast switch +expressions to (int). + Move "-lF77 -lI77 -lm -lc" to link_msg, defined in sysdep.c . + Add #define scrub(x) to sysdep.h, with invocations in format.c and +formatdata.c, so that people who have systems like VMS that would +otherwise create multiple versions of intermediate files can +#define scrub(x) unlink(x) + +Tue Apr 24 18:28:36 EDT 1990: + Pass string lengths once rather than twice to a function of character +arguments involved in comparison of character strings of length 1. + +Fri Apr 27 13:11:52 EDT 1990: + Fix bug that made f2c gag on concatenations involving char(...) on +some systems. + +Sat Apr 28 23:20:16 EDT 1990: + Fix control-stack bug in + if(...) then + else if (complicated condition) + else + endif +(where the complicated condition causes assignment to an auxiliary +variable, e.g., max(a*b,c)). + +Mon Apr 30 13:30:10 EDT 1990: + Change fillers for DATA with holes from substructures to arrays +(in an attempt to make things work right with C compilers that have +funny padding rules for substructures, e.g., Sun C compilers). + Minor cleanup of exec.c (should not affect generated C). + +Mon Apr 30 23:13:51 EDT 1990: + Fix bug in handling return values of functions having multiple +entry points of differing return types. + +Sat May 5 01:45:18 EDT 1990: + Fix type inference bug in + subroutine foo(x) + call goo(x) + end + subroutine goo(i) + i = 3 + end +Instead of warning of inconsistent calling sequences for goo, +f2c was simply making i a real variable; now i is correctly +typed as an integer variable, and f2c issues an error message. + Adjust error messages issued at end of declarations so they +don't blame the first executable statement. + +Sun May 6 01:29:07 EDT 1990: + Fix bug in -P and -Ps: warn when the definition of a subprogram adds +information that would change prototypes or previous declarations. + +Thu May 10 18:09:15 EDT 1990: + Fix further obscure bug with (default) -it: inconsistent calling +sequences and I/O statements could interact to cause a memory fault. +Example: + SUBROUTINE FOO + CALL GOO(' Something') ! Forgot integer first arg + END + SUBROUTINE GOO(IUNIT,MSG) + CHARACTER*(*)MSG + WRITE(IUNIT,'(1X,A)') MSG + END + +Fri May 11 16:49:11 EDT 1990: + Under -!c, do not delete any .c files (when there are errors). + Avoid dereferencing 0 when a fatal error occurs while reading +Fortran on stdin. + +Wed May 16 18:24:42 EDT 1990: + f2c.ps made available. + +Mon Jun 4 12:53:08 EDT 1990: + Diagnose I/O units of invalid type. + Add specific error msg about dummy arguments in common. + +Wed Jun 13 12:43:17 EDT 1990: + Under -A, supply a missing "[1]" for CHARACTER*1 variables that appear +both in a DATA statement and in either COMMON or EQUIVALENCE. + +Mon Jun 18 16:58:31 EDT 1990: + Trivial updates to f2c.ps . ("Fortran 8x" --> "Fortran 90"; omit +"(draft)" from "(draft) ANSI C".) + +Tue Jun 19 07:36:32 EDT 1990: + Fix incorrect code generated for ELSE IF(expression involving +function call passing non-constant substring). + Under -h, preserve the property that strings are null-terminated +where possible. + Remove spaces between # and define in lex.c output.c parse.h . + +Mon Jun 25 07:22:59 EDT 1990: + Minor tweak to makefile to reduce unnecessary recompilations. + +Tue Jun 26 11:49:53 EDT 1990: + Fix unintended truncation of some integer constants on machines +where casting a long to (int) may change the value. E.g., when f2c +ran on machines with 16-bit ints, "i = 99999" was being translated +to "i = -31073;". + +Wed Jun 27 11:05:32 EDT 1990: + Arrange for CHARACTER-valued PARAMETERs to honor their length +specifications. Allow CHAR(nn) in expressions defining such PARAMETERs. + +Fri Jul 20 09:17:30 EDT 1990: + Avoid dereferencing 0 when a FORMAT statement has no label. + +Thu Jul 26 11:09:39 EDT 1990: + Remarks about VOID and binread,binwrite added to README. + Tweaks to parse_args: should be invisible unless your compiler +complained at (short)*store. + +Thu Aug 2 02:07:58 EDT 1990: + f2c.ps: change the first line of page 5 from + include stuff +to + include 'stuff' + +Tue Aug 14 13:21:24 EDT 1990: + libi77: libI77 adjusted to treat tabs as spaces in list input. + +Fri Aug 17 07:24:53 EDT 1990: + libi77: libI77 adjusted so a blank='ZERO' clause (upper case Z) +in an open of a currently open file works right. + +Tue Aug 28 01:56:44 EDT 1990: + Fix bug in warnings of inconsistent calling sequences: if an +argument to a subprogram was never referenced, then a previous +invocation of the subprogram (in the same source file) that +passed something of the wrong type for that argument did not +elicit a warning message. + +Thu Aug 30 09:46:12 EDT 1990: + libi77: prevent embedded blanks in list output of complex values; +omit exponent field in list output of values of magnitude between +10 and 1e8; prevent writing stdin and reading stdout or stderr; +don't close stdin, stdout, or stderr when reopening units 5, 6, 0. + +Tue Sep 4 12:30:57 EDT 1990: + Fix bug in C emitted under -I2 or -i2 for INTEGER*4 FUNCTION. + Warn of missing final END even if there are previous errors. + +Fri Sep 7 13:55:34 EDT 1990: + Remark about "make xsum.out" and "make f2c" added to README. + +Tue Sep 18 23:50:01 EDT 1990: + Fix null dereference (and, on some systems, writing of bogus *_com.c +files) under -ec or -e1c when a prototype file (*.p or *.P) describes +COMMON blocks that do not appear in the Fortran source. + libi77: + Add some #ifdef lines (#ifdef MSDOS, #ifndef MSDOS) to avoid +references to stat and fstat on non-UNIX systems. + On UNIX systems, add component udev to unit; decide that old +and new files are the same iff both the uinode and udev components +of unit agree. + When an open stmt specifies STATUS='OLD', use stat rather than +access (on UNIX systems) to check the existence of the file (in case +directories leading to the file have funny permissions and this is +a setuid or setgid program). + +Thu Sep 27 16:04:09 EDT 1990: + Supply missing entry for Impldoblock in blksize array of cpexpr +(in expr.c). No examples are known where this omission caused trouble. + +Tue Oct 2 22:58:09 EDT 1990: + libf77: test signal(...) == SIG_IGN rather than & 01 in main(). + libi77: adjust rewind.c so two successive rewinds after a write +don't clobber the file. + +Thu Oct 11 18:00:14 EDT 1990: + libi77: minor cleanups: add #include "fcntl.h" to endfile.c, err.c, +open.c; adjust g_char in util.c for segmented memories; in f_inqu +(inquire.c), define x appropriately when MSDOS is defined. + +Mon Oct 15 20:02:11 EDT 1990: + Add #ifdef MSDOS pointer adjustments to mem.c; treat NAME= as a +synonym for FILE= in OPEN statements. + +Wed Oct 17 16:40:37 EDT 1990: + libf77, libi77: minor cleanups: _cleanup() and abort() invocations +replaced by invocations of sig_die in main.c; some error messages +previously lost in buffers will now appear. + +Mon Oct 22 16:11:27 EDT 1990: + libf77: separate sig_die from main (for folks who don't want to use +the main in libF77). + libi77: minor tweak to comments in README. + +Fri Nov 2 13:49:35 EST 1990: + Use two underscores rather than one in generated temporary variable +names to avoid conflict with COMMON names. f2c.ps updated to reflect +this change and the NAME= extension introduced 15 Oct. + Repair a rare memory fault in io.c . + +Mon Nov 5 16:43:55 EST 1990: + libi77: changes to open.c (and err.c): complain if an open stmt +specifies new= and the file already exists (as specified by Fortrans 77 +and 90); allow file= to be omitted in open stmts and allow +status='replace' (Fortran 90 extensions). + +Fri Nov 30 10:10:14 EST 1990: + Adjust malloc.c for unusual systems whose sbrk() can return values +not properly aligned for doubles. + Arrange for slightly more helpful and less repetitive warnings for +non-character variables initialized with character data; these warnings +are (still) suppressed by -w66. + +Fri Nov 30 15:57:59 EST 1990: + Minor tweak to README (about changing VOID in f2c.h). + +Mon Dec 3 07:36:20 EST 1990: + Fix spelling of "character" in f2c.1t. + +Tue Dec 4 09:48:56 EST 1990: + Remark about link_msg and libf2c added to f2c/README. + +Thu Dec 6 08:33:24 EST 1990: + Under -U, render label nnn as L_nnn rather than Lnnn. + +Fri Dec 7 18:05:00 EST 1990: + Add more names from f2c.h (e.g. integer, real) to the c_keywords +list of names to which an underscore is appended to avoid confusion. + +Mon Dec 10 19:11:15 EST 1990: + Minor tweaks to makefile (./xsum) and README (binread/binwrite). + libi77: a few modifications for POSIX systems; meant to be invisible +elsewhere. + +Sun Dec 16 23:03:16 EST 1990: + Fix null dereference caused by unusual erroneous input, e.g. + call foo('abc') + end + subroutine foo(msg) + data n/3/ + character*(*) msg + end +(Subroutine foo is illegal because the character statement comes after a +data statement.) + Use decimal rather than hex constants in xsum.c (to prevent +erroneous warning messages about constant overflow). + +Mon Dec 17 12:26:40 EST 1990: + Fix rare extra underscore in character length parameters passed +for multiple entry points. + +Wed Dec 19 17:19:26 EST 1990: + Allow generation of C despite error messages about bad alignment +forced by equivalence. + Allow variable-length concatenations in I/O statements, such as + open(3, file=bletch(1:n) // '.xyz') + +Fri Dec 28 17:08:30 EST 1990: + Fix bug under -p with formats and internal I/O "units" in COMMON, +as in + COMMON /FIGLEA/F + CHARACTER*20 F + F = '(A)' + WRITE (*,FMT=F) 'Hello, world!' + END + +Tue Jan 15 12:00:24 EST 1991: + Fix bug when two equivalence groups are merged, the second with +nonzero offset, and the result is then merged into a common block. +Example: + INTEGER W(3), X(3), Y(3), Z(3) + COMMON /ZOT/ Z + EQUIVALENCE (W(1),X(1)), (X(2),Y(1)), (Z(3),X(1)) +***** W WAS GIVEN THE WRONG OFFSET + Recognize Fortran 90's optional NML= in NAMELIST READs and WRITEs. +(Currently NML= and FMT= are treated as synonyms -- there's no +error message if, e.g., NML= specifies a format.) + libi77: minor adjustment to allow internal READs from character +string constants in read-only memory. + +Fri Jan 18 22:56:15 EST 1991: + Add comment to README about needing to comment out the typedef of +size_t in sysdep.h on some systems, e.g. Sun 4.1. + Fix misspelling of "statement" in an error message in lex.c + +Wed Jan 23 00:38:48 EST 1991: + Allow hex, octal, and binary constants to have the qualifying letter +(z, x, o, or b) either before or after the quoted string containing the +digits. For now this change will not be reflected in f2c.ps . + +Tue Jan 29 16:23:45 EST 1991: + Arrange for character-valued statement functions to give results of +the right length (that of the statement function's name). + +Wed Jan 30 07:05:32 EST 1991: + More tweaks for character-valued statement functions: an error +check and an adjustment so a right-hand side of nonconstant length +(e.g., a substring) is handled right. + +Wed Jan 30 09:49:36 EST 1991: + Fix p1_head to avoid printing (char *)0 with %s. + +Thu Jan 31 13:53:44 EST 1991: + Add a test after the cleanup call generated for I/O statements with +ERR= or END= clauses to catch the unlikely event that the cleanup +routine encounters an error. + +Mon Feb 4 08:00:58 EST 1991: + Minor cleanup: omit unneeded jumps and labels from code generated for +some NAMELIST READs and WRITEs with IOSTAT=, ERR=, and/or END=. + +Tue Feb 5 01:39:36 EST 1991: + Change Mktemp to mktmp (for the benefit of systems so brain-damaged +that they do not distinguish case in external names -- and that for +some reason want to load mktemp). Try to get xsum0.out right this +time (it somehow didn't get updated on 4 Feb. 1991). + Add note to libi77/README about adjusting the interpretation of +RECL= specifiers in OPENs for direct unformatted I/O. + +Thu Feb 7 17:24:42 EST 1991: + New option -r casts values of REAL functions, including intrinsics, +to REAL. This only matters for unportable code like + real r + r = asin(1.) + if (r .eq. asin(1.)) ... +[The behavior of such code varies with the Fortran compiler used -- +and sometimes is affected by compiler options.] For now, the man page +at the end of f2c.ps is the only part of f2c.ps that reflects this new +option. + +Fri Feb 8 18:12:51 EST 1991: + Cast pointer differences passed as arguments to the appropriate type. +This matters, e.g., with MSDOS compilers that yield a long pointer +difference but have int == short. + Disallow nonpositive dimensions. + +Fri Feb 15 12:24:15 EST 1991: + Change %d to %ld in sprintf call in putpower in putpcc.c. + Free more memory (e.g. allowing translation of larger Fortran +files under MS-DOS). + Recognize READ (character expression) and WRITE (character expression) +as formatted I/O with the format given by the character expression. + Update year in Notice. + +Sat Feb 16 00:42:32 EST 1991: + Recant recognizing WRITE(character expression) as formatted output +-- Fortran 77 is not symmetric in its syntax for READ and WRITE. + +Mon Mar 4 15:19:42 EST 1991: + Fix bug in passing the real part of a complex argument to an intrinsic +function. Omit unneeded parentheses in nested calls to intrinsics. +Example: + subroutine foo(x, y) + complex y + x = exp(sin(real(y))) + exp(imag(y)) + end + +Fri Mar 8 15:05:42 EST 1991: + Fix a comment in expr.c; omit safstrncpy.c (which had bugs in +cases not used by f2c). + +Wed Mar 13 02:27:23 EST 1991: + Initialize firstmemblock->next in mem_init in mem.c . [On most +systems it was fortuituously 0, but with System V, -lmalloc could +trip on this missed initialization.] + +Wed Mar 13 11:47:42 EST 1991: + Fix a reference to freed memory. + +Wed Mar 27 00:42:19 EST 1991: + Fix a memory fault caused by such illegal Fortran as + function foo + x = 3 + logical foo ! declaration among executables + foo=.false. ! used to suffer memory fault + end + +Fri Apr 5 08:30:31 EST 1991: + Fix loss of % in some format expressions, e.g. + write(*,'(1h%)') + Fix botch introduced 27 March 1991 that caused subroutines with +multiple entry points to have extraneous declarations of ret_val. + +Fri Apr 5 12:44:02 EST 1991 + Try again to omit extraneous ret_val declarations -- this morning's +fix was sometimes wrong. + +Mon Apr 8 13:47:06 EDT 1991: + Arrange for s_rnge to have the right prototype under -A -C . + +Wed Apr 17 13:36:03 EDT 1991: + New fatal error message for apparent invocation of a recursive +statement function. + +Thu Apr 25 15:13:37 EDT 1991: + F2c and libi77 adjusted so NAMELIST works with -i2. (I forgot +about -i2 when adding NAMELIST.) This required a change to f2c.h +(that only affects NAMELIST I/O under -i2.) Man-page description of +-i2 adjusted to reflect that -i2 stores array lengths in short ints. + +Fri Apr 26 02:54:41 EDT 1991: + Libi77: fix some bugs in NAMELIST reading of multi-dimensional arrays +(file rsne.c). + +Thu May 9 02:13:51 EDT 1991: + Omit a trailing space in expr.c (could cause a false xsum value if +a mailer drops the trailing blank). + +Thu May 16 13:14:59 EDT 1991: + Libi77: increase LEFBL in lio.h to overcome a NeXT bug. + Tweak for compilers that recognize "nested" comments: inside comments, +turn /* into /+ (as well as */ into +/). + +Sat May 25 11:44:25 EDT 1991: + libf77: s_rnge: declare line long int rather than int. + +Fri May 31 07:51:50 EDT 1991: + libf77: system_: officially return status. + +Mon Jun 17 16:52:53 EDT 1991: + Minor tweaks: omit unnecessary declaration of strcmp (that caused +trouble on a system where strcmp was a macro) from misc.c; add +SHELL = /bin/sh to makefiles. + Fix a dereference of null when a CHARACTER*(*) declaration appears +(illegally) after DATA. Complain only once per subroutine about +declarations appearing after DATA. + +Mon Jul 1 00:28:13 EDT 1991: + Add test and error message for illegal use of subroutine names, e.g. + SUBROUTINE ZAP(A) + ZAP = A + END + +Mon Jul 8 21:49:20 EDT 1991: + Issue a warning about things like + integer i + i = 'abc' +(which is treated as i = ichar('a')). [It might be nice to treat 'abc' +as an integer initialized (in a DATA statement) with 'abc', but +other matters have higher priority.] + Render + i = ichar('A') +as + i = 'A'; +rather than + i = 65; +(which assumes ASCII). + +Fri Jul 12 07:41:30 EDT 1991: + Note added to README about erroneous definitions of __STDC__ . + +Sat Jul 13 13:38:54 EDT 1991: + Fix bugs in double type convesions of complex values, e.g. +sngl(real(...)) or dble(real(...)) (where ... is complex). + +Mon Jul 15 13:21:42 EDT 1991: + Fix bug introduced 8 July 1991 that caused erroneous warnings +"ichar([first char. of] char. string) assumed for conversion to numeric" +when a subroutine had an array of character strings as an argument. + +Wed Aug 28 01:12:17 EDT 1991: + Omit an unused function in format.c, an unused variable in proc.c . + Under -r8, promote complex to double complex (as the man page claims). + +Fri Aug 30 17:19:17 EDT 1991: + f2c.ps updated: slightly expand description of intrinsics and,or,xor, +not; add mention of intrinsics lshift, rshift; add note about f2c +accepting Fortran 90 inline comments (starting with !); update Cobalt +Blue address. + +Tue Sep 17 07:17:33 EDT 1991: + libI77: err.c and open.c modified to use modes "rb" and "wb" +when (f)opening unformatted files; README updated to point out +that it may be necessary to change these modes to "r" and "w" +on some non-ANSI systems. + +Tue Oct 15 10:25:49 EDT 1991: + Minor tweaks that make some PC compilers happier: insert some +casts, add args to signal functions. + Change -g to emit uncommented #line lines -- and to emit more of them; +update fc, f2c.1, f2c.1t, f2c.ps to reflect this. + Change uchar to Uchar in xsum.c . + Bring gram.c up to date. + +Thu Oct 17 09:22:05 EDT 1991: + libi77: README, fio.h, sue.c, uio.c changed so the length field +in unformatted sequential records has type long rather than int +(unless UIOLEN_int is #defined). This is for systems where sizeof(int) +can vary, depending on the compiler or compiler options. + +Thu Oct 17 13:42:59 EDT 1991: + libi77: inquire.c: when MSDOS is defined, don't strcmp units[i].ufnm +when it is NULL. + +Fri Oct 18 15:16:00 EDT 1991: + Correct xsum0.out in "all from f2c/src" (somehow botched on 15 Oct.). + +Tue Oct 22 18:12:56 EDT 1991: + Fix memory fault when a character*(*) argument is used (illegally) +as a dummy variable in the definition of a statement function. (The +memory fault occurred when the statement function was invoked.) + Complain about implicit character*(*). + +Thu Nov 14 08:50:42 EST 1991: + libi77: change uint to Uint in fmt.h, rdfmt.c, wrtfmt.c; this change +should be invisible unless you're running a brain-damaged system. + +Mon Nov 25 19:04:40 EST 1991: + libi77: correct botches introduced 17 Oct. 1991 and 14 Nov. 1991 +(change uint to Uint in lwrite.c; other changes that only matter if +sizeof(int) != sizeof(long)). + Add a more meaningful error message when bailing out due to an attempt +to invoke a COMMON variable as a function. + +Sun Dec 1 19:29:24 EST 1991: + libi77: uio.c: add test for read failure (seq. unformatted reads); +adjust an error return from EOF to off end of record. + +Tue Dec 10 17:42:28 EST 1991: + Add tests to prevent memory faults with bad uses of character*(*). + +Thu Dec 12 11:24:41 EST 1991: + libi77: fix bug with internal list input that caused the last +character of each record to be ignored; adjust error message in +internal formatted input from "end-of-file" to "off end of record" +if the format specifies more characters than the record contains. + +Wed Dec 18 17:48:11 EST 1991: + Fix bug in translating nonsensical ichar invocations involving +concatenations. + Fix bug in passing intrinsics lle, llt, lge, lgt as arguments; +hl_le was being passed rather than l_le, etc. + libf77: adjust length parameters from long to ftnlen, for +compiling with f2c_i2 defined. + +Sat Dec 21 15:30:57 EST 1991: + Allow DO nnn ... to end with an END DO statement labelled nnn. + +Tue Dec 31 13:53:47 EST 1991: + Fix bug in handling dimension a(n**3,2) -- pow_ii was called +incorrectly. + Fix bug in translating + subroutine x(abc,n) + character abc(n) + write(abc,'(i10)') 123 + end +(omitted declaration and initialiation of abc_dim1). + Complain about dimension expressions of such invalid types +as complex and logical. + +Fri Jan 17 11:54:20 EST 1992: + Diagnose some illegal uses of main program name (rather than +memory faulting). + libi77: (1) In list and namelist input, treat "r* ," and "r*," +alike (where r is a positive integer constant), and fix a bug in +handling null values following items with repeat counts (e.g., +2*1,,3). (2) For namelist reading of a numeric array, allow a new +name-value subsequence to terminate the current one (as though the +current one ended with the right number of null values). +(3) [lio.h, lwrite.c]: omit insignificant zeros in list and namelist +output. (Compile with -DOld_list_output to get the old behavior.) + +Sat Jan 18 15:58:01 EST 1992: + libi77: make list output consistent with F format by printing .1 +rather than 0.1 (introduced yesterday). + +Wed Jan 22 08:32:43 EST 1992: + libi77: add comment to README pointing out preconnection of +Fortran units 5, 6, 0 to stdin, stdout, stderr (respectively). + +Mon Feb 3 11:57:53 EST 1992: + libi77: fix namelist read bug that caused the character following +a comma to be ignored. + +Fri Feb 28 01:04:26 EST 1992: + libf77: fix buggy z_sqrt.c (double precision square root), which +misbehaved for arguments in the southwest quadrant. + +Thu Mar 19 15:05:18 EST 1992: + Fix bug (introduced 17 Jan 1992) in handling multiple entry points +of differing types (with implicitly typed entries appearing after +the first executable statement). + Fix memory fault in the following illegal Fortran: + double precision foo(i) +* illegal: above should be "double precision function foo(i)" + foo = i * 3.2 + entry moo(i) + end + Note about ANSI_Libraries (relevant, e.g., to IRIX 4.0.1 and AIX) +added to README. + Abort zero divides during constant simplification. + +Sat Mar 21 01:27:09 EST 1992: + Tweak ckalloc (misc.c) for systems where malloc(0) = 0; this matters +for subroutines with multiple entry points but no arguments. + Add "struct memblock;" to init.c (irrelevant to most compilers). + +Wed Mar 25 13:31:05 EST 1992: + Fix bug with IMPLICIT INTEGER*4(...): under -i2 or -I2, the *4 was +ignored. + +Tue May 5 09:53:55 EDT 1992: + Tweaks to README; e.g., ANSI_LIbraries changed to ANSI_Libraries . + +Wed May 6 23:49:07 EDT 1992 + Under -A and -C++, have subroutines return 0 (even if they have +no * arguments). + Adjust libi77 (rsne.c and lread.c) for systems where ungetc is +a macro. Tweak lib[FI]77/makefile to use unique intermediate file +names (for parallel makes). + +Tue May 19 09:03:05 EDT 1992: + Adjust libI77 to make err= work with internal list and formatted I/O. + +Sat May 23 18:17:42 EDT 1992: + Under -A and -C++, supply "return 0;" after the code generated for +a STOP statement -- the C compiler doesn't know that s_stop won't +return. + New (mutually exclusive) options: + -f treats all input lines as free-format lines, + honoring text that appears after column 72 + and not padding lines shorter than 72 characters + with blanks (which matters if a character string + is continued across 2 or more lines). + -72 treats text appearing after column 72 as an error. + +Sun May 24 09:45:37 EDT 1992: + Tweak description of -f in f2c.1 and f2c.1t; update f2c.ps . + +Fri May 29 01:17:15 EDT 1992: + Complain about externals used as variables. Example + subroutine foo(a,b) + external b + a = a*b ! illegal use of b; perhaps should be b() + end + +Mon Jun 15 11:15:27 EDT 1992: + Fix bug in handling namelists with names that have underscores. + +Sat Jun 27 17:30:59 EDT 1992: + Under -A and -C++, end Main program aliases with "return 0;". + Under -A and -C++, use .P files and usage in previous subprograms +in the current file to give prototypes for functions declared EXTERNAL +but not invoked. + Fix memory fault under -d1 -P . + Under -A and -C++, cast arguments to the right types in calling +a function that has been defined in the current file or in a .P file. + Fix bug in handling multi-dimensional arrays with array references +in their leading dimensions. + Fix bug in the intrinsic cmplx function when the first argument +involves an expression for which f2c generates temporary variables, +e.g. cmplx(abs(real(a)),1.) . + +Sat Jul 18 07:36:58 EDT 1992: + Fix buglet with -e1c (invisible on most systems) temporary file +f2c_functions was unlinked before being closed. + libf77: fix bugs in evaluating m**n for integer n < 0 and m an +integer different from 1 or a real or double precision 0. +Catch SIGTRAP (to print "Trace trap" before aborting). Programs +that previously erroneously computed 1 for 0**-1 may now fault. +Relevant routines: main.c pow_di.c pow_hh.c pow_ii.c pow_ri.c . + +Sat Jul 18 08:40:10 EDT 1992: + libi77: allow namelist input to end with & (e.g. &end). + +Thu Jul 23 00:14:43 EDT 1992 + Append two underscores rather than one to C keywords used as +local variables to avoid conflicts with similarly named COMMON blocks. + +Thu Jul 23 11:20:55 EDT 1992: + libf77, libi77 updated to assume ANSI prototypes unless KR_headers +is #defined. + libi77 now recognizes a Z format item as in Fortran 90; +the implementation assumes 8-bit bytes and botches character strings +on little-endian machines (by printing their bytes from right to +left): expect this bug to persist; fixing it would require a +change to the I/O calling sequences. + +Tue Jul 28 15:18:33 EDT 1992: + libi77: insert missed "#ifdef KR_headers" lines around getnum +header in rsne.c. Version not updated. + +NOTE: "index from f2c" now ends with current timestamps of files in +"all from f2c/src", sorted by time. To bring your source up to date, +obtain source files with a timestamp later than the time shown in your +version.c. + +Fri Aug 14 08:07:09 EDT 1992: + libi77: tweak wrt_E in wref.c to avoid signing NaNs. + +Sun Aug 23 19:05:22 EDT 1992: + fc: supply : after O in getopt invocation (for -O1 -O2 -O3). + +Mon Aug 24 18:37:59 EDT 1992: + Recant above tweak to fc: getopt is dumber than I thought; +it's necessary to say -O 1 (etc.). + libF77/README: add comments about ABORT, ERF, DERF, ERFC, DERFC, +GETARG, GETENV, IARGC, SIGNAL, and SYSTEM. + +Tue Oct 27 01:57:42 EST 1992: + libf77, libi77: + 1. Fix botched indirection in signal_.c. + 2. Supply missing l_eof = 0 assignment to s_rsne() in rsne.c (so +end-of-file on other files won't confuse namelist reads of external +files). + 3. Prepend f__ to external names that are only of internal +interest to lib[FI]77. + +Thu Oct 29 12:37:18 EST 1992: + libf77: Fix botch in signal_.c when KR_headers is #defined; +add CFLAGS to makefile. + libi77: trivial change to makefile for consistency with +libF77/makefile. + +Wed Feb 3 02:05:16 EST 1993: + Recognize types INTEGER*1, LOGICAL*1, LOGICAL*2, INTEGER*8. +INTEGER*8 is not well tested and will only work reasonably on +systems where int = 4 bytes, long = 8 bytes; on such systems, +you'll have to modify f2c.h appropriately, changing integer +from long to int and adding typedef long longint. You'll also +have to compile libI77 with Allow_TYQUAD #defined and adjust +libF77/makefile to compile pow_qq.c. In the f2c source, changes +for INTEGER*8 are delimited by #ifdef TYQUAD ... #endif. You +can omit the INTEGER*8 changes by compiling with NO_TYQUAD +#defined. Otherwise, the new command-line option -!i8 +disables recognition of INTEGER*8. + libf77: add pow_qq.c + libi77: add #ifdef Allow_TYQUAD stuff. Changes for INTEGER*1, +LOGICAL*1, and LOGICAL*2 came last 23 July 1992. Fix bug in +backspace (that only bit when the last character of the second +or subsequent buffer read was the previous newline). Guard +against L_tmpnam being too small in endfile.c. For MSDOS, +close and reopen files when copying to truncate. Lengthen +LINTW (buffer size in lwrite.c). + Add \ to the end of #define lines that get broken. + Fix bug in handling NAMELIST of items in EQUIVALENCE. + Under -h (or -hd), convert Hollerith to integer in general expressions +(e.g., assignments), not just when they're passed as arguments, and +blank-pad rather than 0-pad the Hollerith to a multiple of +sizeof(integer) or sizeof(doublereal). + Add command-line option -s, which instructs f2c preserve multi- +dimensional subscripts (by emitting and using appropriate #defines). + Fix glitch (with default type inferences) in examples like + call foo('abc') + end + subroutine foo(goo) + end +This gave two warning messages: + Warning on line 4 of y.f: inconsistent calling sequences for foo: + here 1, previously 2 args and string lengths. + Warning on line 4 of y.f: inconsistent calling sequences for foo: + here 2, previously 1 args and string lengths. +Now the second Warning is suppressed. + Complain about all inconsistent arguments, not just the first. + Switch to automatic creation of "all from f2c/src". For folks +getting f2c source via ftp, this means f2c/src/all.Z is now an +empty file rather than a bundle. + Separate -P and -A: -P no longer implies -A. + +Thu Feb 4 00:32:20 EST 1993: + Fix some glitches (introduced yesterday) with -h . + +Fri Feb 5 01:40:38 EST 1993: + Fix bug in types conveyed for namelists (introduced 3 Feb. 1993). + +Fri Feb 5 21:26:43 EST 1993: + libi77: tweaks to NAMELIST and open (after comments by Harold +Youngren): + 1. Reading a ? instead of &name (the start of a namelist) causes + the namelist being sought to be written to stdout (unit 6); + to omit this feature, compile rsne.c with -DNo_Namelist_Questions. + 2. Reading the wrong namelist name now leads to an error message + and an attempt to skip input until the right namelist name is found; + to omit this feature, compile rsne.c with -DNo_Bad_Namelist_Skip. + 3. Namelist writes now insert newlines before each variable; to omit + this feature, compile xwsne.c with -DNo_Extra_Namelist_Newlines. + 4. For OPEN of sequential files, ACCESS='APPEND' (or + access='anything else starting with "A" or "a"') causes the file to + be positioned at end-of-file, so a write will append to the file. + (This is nonstandard, but does not require modifying data + structures.) + +Mon Feb 8 14:40:37 EST 1993: + Increase number of continuation lines allowed from 19 to 99, +and allow changing this limit with -NC (e.g. -NC200 for 200 lines). + Treat control-Z (at the beginning of a line) as end-of-file: see +the new penultimate paragraph of README. + Fix a rarely seen glitch that could make an error messages to say +"line 0". + +Tue Feb 9 02:05:40 EST 1993 + libi77: change some #ifdef MSDOS lines to #ifdef NON_UNIX_STDIO, +and, in err.c under NON_UNIX_STDIO, avoid close(creat(name,0666)) +when the unit has another file descriptor for name. + +Tue Feb 9 17:12:49 EST 1993 + libi77: more tweaks for NON_UNIX_STDIO: use stdio routines +rather than open, close, creat, seek, fdopen (except for f__isdev). + +Fri Feb 12 15:49:33 EST 1993 + Update src/gram.c (which was forgotten in the recent updates). +Most folks regenerate it anyway (wity yacc or bison). + +Thu Mar 4 17:07:38 EST 1993 + Increase default max labels in computed gotos and alternate returns +to 257, and allow -Nl1234 to specify this number. + Tweak put.c to check p->tag == TADDR in realpart() and imagpart(). + Adjust fc script to allow .r (RATFOR) files and -C (check subscripts). + Avoid declaring strchr in niceprintf.c under -DANSI_Libraries . + gram.c updated again. + libi77: err.c, open.c: take declaration of fdopen from rawio.h. + +Sat Mar 6 07:09:11 EST 1993 + libi77: uio.c: adjust off-end-of-record test for sequential +unformatted reads to respond to err= rather than end= . + +Sat Mar 6 16:12:47 EST 1993 + Treat scalar arguments of the form (v) and v+0, where v is a variable, +as expressions: assign to a temporary variable, and pass the latter. + gram.c updated. + +Mon Mar 8 09:35:38 EST 1993 + "f2c.h from f2c" updated to add types logical1 and integer1 for +LOGICAL*1 and INTEGER*1. ("f2c.h from f2c" is supposed to be the +same as "f2c.h from f2c/src", which was updated 3 Feb. 1993.) + +Mon Mar 8 17:57:55 EST 1993 + Fix rarely seen bug that could cause strange casts in function +invocations (revealed by an example with msdos/f2c.exe). + msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only). + +Fri Mar 12 12:37:01 EST 1993 + Fix bug with -s in handling subscripts involving min, max, and +complicated expressions requiring temporaries. + Fix bug in handling COMMONs that need padding by a char array. + msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only). + +Fri Mar 12 17:16:16 EST 1993 + libf77, libi77: updated for compiling under C++. + +Mon Mar 15 16:21:37 EST 1993 + libi77: more minor tweaks (for -DKR_headers); Version.c not changed. + +Thu Mar 18 12:37:30 EST 1993 + Flag -r (for discarding carriage-returns on systems that end lines +with carriage-return/newline pairs, e.g. PCs) added to xsum, and +xsum.c converted to ANSI/ISO syntax (with K&R syntax available with +-DKR_headers). [When time permits, the f2c source will undergo a +similar conversion.] + libi77: tweaks to #includes in endfile.c, err.c, open.c, rawio.h; +Version.c not changed. + f2c.ps updated (to pick up revision of 2 Feb. 1993 to f2c.1). + +Fri Mar 19 09:19:26 EST 1993 + libi77: add (char *) casts to malloc and realloc invocations +in err.c, open.c; Version.c not changed. + +Tue Mar 30 07:17:15 EST 1993 + Fix bug introduced 6 March 1993: possible memory corruption when +loops in data statements involve constant subscripts, as in + DATA (GUNIT(1,I),I=0,14)/15*-1/ + +Tue Mar 30 16:17:42 EST 1993 + Fix bug with -s: (floating-point array item)*(complex item) +generates an _subscr() reference for the floating-point array, +but a #define for the _subscr() was omitted. + +Tue Apr 6 12:11:22 EDT 1993 + libi77: adjust error returns for formatted inputs to flush the current +input line when err= is specified. To restore the old behavior (input +left mid-line), either adjust the #definition of errfl in fio.h or omit +the invocation of f__doend in err__fl (in err.c). + +Tue Apr 6 13:30:04 EDT 1993 + Fix bug revealed in + subroutine foo(i) + call goo(int(i)) + end +which now passes a copy of i, rather than i itself. + +Sat Apr 17 11:41:02 EDT 1993 + Adjust appending of underscores to conform with f2c.ps ("A Fortran +to C Converter"): names that conflict with C keywords or f2c type +names now have just one underscore appended (rather than two); add +"integer1", "logical1", "longint" to the keyword list. + Append underscores to names that appear in EQUIVALENCE and are +component names in a structure declared in f2c.h, thus avoiding a +problem caused by the #defines emitted for equivalences. Example: + complex a + equivalence (i,j) + a = 1 ! a.i went awry because of #define i + j = 2 + write(*,*) a, i + end + Adjust line-breaking logic to avoid splitting very long constants +(and names). Example: + ! The next line starts with tab and thus is a free-format line. + a=.012345689012345689012345689012345689012345689012345689012345689012345689 + end + Omit extraneous "return 0;" from entry stubs emitted for multiple +entry points of type character, complex, or double complex. + +Sat Apr 17 14:35:05 EDT 1993 + Fix bug (introduced 4 Feb.) in separating -P from -A that kept f2c +from re-reading a .P file written without -A or -C++ describing a +routine with an external argument. [See the just-added note about +separating -P from -A in the changes above for 3 Feb. 1993.] + Fix bug (type UNKNOWN for V in the example below) revealed by + subroutine a() + external c + call b(c) + end + subroutine b(v) + end + +Sun Apr 18 19:55:26 EDT 1993 + Fix wrong calling sequence for mem() in yesterday's addition to +equiv.c . + +Wed Apr 21 17:39:46 EDT 1993 + Fix bug revealed in + + ASSIGN 10 TO L1 + GO TO 20 + 10 ASSIGN 30 TO L2 + STOP 10 + + 20 ASSIGN 10 TO L2 ! Bug here because 10 had been assigned + ! to another label, then defined. + GO TO L2 + 30 END + +Fri Apr 23 18:38:50 EDT 1993 + Fix bug with -h revealed in + CHARACTER*9 FOO + WRITE(FOO,'(I6)') 1 + WRITE(FOO,'(I6)') 2 ! struct icilist io___3 botched + END + +Tue Apr 27 16:08:28 EDT 1993 + Tweak to makefile: remove "size f2c". + +Tue May 4 23:48:20 EDT 1993 + libf77: tweak signal_ line of f2ch.add . + +Tue Jun 1 13:47:13 EDT 1993 + Fix bug introduced 3 Feb. 1993 in handling multiple entry +points with differing return types -- the postfix array in proc.c +needed a new entry for integer*8 (which resulted in wrong +Multitype suffixes for non-integral types). + For (default) K&R C, generate VOID rather than int functions for +functions of Fortran type character, complex, and double complex. + msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only). + +Tue Jun 1 23:11:15 EDT 1993 + f2c.h: add Multitype component g and commented type longint. + proc.c: omit "return 0;" from stubs for complex and double complex +entries (when entries have multiple types); add test to avoid memory +fault with illegal combinations of entry types. + +Mon Jun 7 12:00:47 EDT 1993 + Fix memory fault in + common /c/ m + integer m(1) + data m(1)/1/, m(2)/2/ ! one too many initializers + end + msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only). + +Fri Jun 18 13:55:51 EDT 1993 + libi77: change type of signal_ in f2ch.add; change type of il in +union Uint from long to integer (for machines like the DEC Alpha, +where integer should be the same as int). Version.c not changed. + Tweak gram.dcl and gram.head: add semicolons after some rules that +lacked them, and remove an extraneous semicolon. These changes are +completely transparent to our local yacc programs, but apparently +matter on some VMS systems. + +Wed Jun 23 01:02:56 EDT 1993 + Update "fc" shell script, and bring f2c.1 and f2c.1t up to date: +they're meant to be linked with (i.e., the same as) src/f2c.1 and +src/f2c.1t . [In the last update of f2c.1* (2 Feb. 1993), only +src/f2c.1 and src/f2c.1t got changed -- a mistake.] + +Wed Jun 23 09:04:31 EDT 1993 + libi77: fix bug in format reversions for internal writes. +Example: + character*60 lines(2) + write(lines,"('n =',i3,2(' more text',i3))") 3, 4, 5, 6 + write(*,*) 'lines(1) = ', lines(1) + write(*,*) 'lines(2) = ', lines(2) + end +gave an error message that began "iio: off end of record", rather +than giving the correct output: + + lines(1) = n = 3 more text 4 more text 5 + lines(2) = more text 6 more text + +Thu Aug 5 11:31:14 EDT 1993 + libi77: lread.c: fix bug in handling repetition counts for logical +data (during list or namelist input). Change struct f__syl to +struct syl (for buggy compilers). + +Sat Aug 7 16:05:30 EDT 1993 + libi77: lread.c (again): fix bug in namelist reading of incomplete +logical arrays. + Fix minor calling-sequence errors in format.c, output.c, putpcc.c: +should be invisible. + +Mon Aug 9 09:12:38 EDT 1993 + Fix erroneous cast under -A in translating + character*(*) function getc() + getc(2:3)=' ' !wrong cast in first arg to s_copy + end + libi77: lread.c: fix bug in namelist reading of an incomplete array +of numeric data followed by another namelist item whose name starts +with 'd', 'D', 'e', or 'E'. + +Fri Aug 20 13:22:10 EDT 1993 + Fix bug in do while revealed by + subroutine skdig (line, i) + character line*(*), ch*1 + integer i + logical isdigit + isdigit(ch) = ch.ge.'0' .and. ch.le.'9' + do while (isdigit(line(i:i))) ! ch__1[0] was set before + ! "while(...) {...}" + i = i + 1 + enddo + end + +Fri Aug 27 08:22:54 EDT 1993 + Add #ifdefs to avoid declaring atol when it is a macro; version.c +not updated. + +Wed Sep 8 12:24:26 EDT 1993 + libi77: open.c: protect #include "sys/..." with +#ifndef NON_UNIX_STDIO; Version date not changed. + +Thu Sep 9 08:51:21 EDT 1993 + Adjust "include" to interpret file names relative to the directory +of the file that contains the "include". + +Fri Sep 24 00:56:12 EDT 1993 + Fix offset error resulting from repeating the same equivalence +statement twice. Example: + real a(2), b(2) + equivalence (a(2), b(2)) + equivalence (a(2), b(2)) + end + Increase MAXTOKENLEN (to roughly the largest allowed by ANSI C). + +Mon Sep 27 08:55:09 EDT 1993 + libi77: endfile.c: protect #include "sys/types.h" with +#ifndef NON_UNIX_STDIO; Version.c not changed. + +Fri Oct 15 15:37:26 EDT 1993 + Fix rarely seen parsing bug illustrated by + subroutine foo(xabcdefghij) + character*(*) xabcdefghij + IF (xabcdefghij.NE.'##') GOTO 40 + 40 end +in which the spacing in the IF line is crucial. + +Thu Oct 21 13:55:11 EDT 1993 + Give more meaningful error message (then "unexpected character in +cds") when constant simplification leads to Infinity or NaN. + +Wed Nov 10 15:01:05 EST 1993 + libi77: backspace.c: adjust, under -DMSDOS, to cope with MSDOS +text files, as handled by some popular PC C compilers. Beware: +the (defective) libraries associated with these compilers assume lines +end with \r\n (conventional MS-DOS text files) -- and ftell (and +hence the current implementation of backspace) screws up if lines with +just \n. + +Thu Nov 18 09:37:47 EST 1993 + Give a better error (than "control stack empty") for an extraneous +ENDDO. Example: + enddo + end + Update comments about ftp in "readme from f2c". + +Sun Nov 28 17:26:50 EST 1993 + Change format of time stamp in version.c to yyyymmdd. + Sort parameter adjustments (or complain of impossible dependencies) +so that dummy arguments are referenced only after being adjusted. +Example: + subroutine foo(a,b) + integer a(2) ! a must be adjusted before b + double precision b(a(1),a(2)) + call goo(b(3,4)) + end + Adjust structs for initialized common blocks and equivalence classes +to omit the trailing struct component added to force alignment when +padding already forces the desired alignment. Example: + PROGRAM TEST + COMMON /Z/ A, CC + CHARACTER*4 CC + DATA cc /'a'/ + END +now gives + struct { + integer fill_1[1]; + char e_2[4]; + } z_ = { {0}, {'a', ' ', ' ', ' '} }; +rather than +struct { + integer fill_1[1]; + char e_2[4]; + real e_3; + } z_ = { {0}, {'a', ' ', ' ', ' '}, (float)0. }; + +Wed Dec 8 16:24:43 EST 1993 + Adjust lex.c to recognize # nnn "filename" lines emitted by cpp; +this affects the file names and line numbers in error messages and +the #line lines emitted under -g. + Under -g, arrange for a file that starts with an executable +statement to have the first #line line indicate line 1, rather +than the line number of the END statement ending the main program. + Adjust fc script to run files ending in .F through /lib/cpp. + Fix bug ("Impossible tag 2") in + if (t .eq. (0,2)) write(*,*) 'Bug!' + end + libi77: iio.c: adjust internal formatted reads to treat short records +as though padded with blanks (rather than causing an "off end of record" +error). + +Wed Dec 15 15:19:15 EST 1993 + fc: adjusted for .F files to pass -D and -I options to cpp. + +Fri Dec 17 20:03:38 EST 1993 + Fix botch introduced 28 Nov. 1993 in vax.c; change "version of" +to "version". + +Tue Jan 4 15:39:52 EST 1994 + msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only). + +Wed Jan 19 08:55:19 EST 1994 + Arrange to accept + integer Nx, Ny, Nz + parameter (Nx = 10, Ny = 20) + parameter (Nz = max(Nx, Ny)) + integer c(Nz) + call foo(c) + end +rather than complaining "Declaration error for c: adjustable dimension +on non-argument". The necessary changes cause some hitherto unfolded +constant expressions to be folded. + Accept BYTE as a synonym for INTEGER*1. + +Thu Jan 27 08:57:40 EST 1994 + Fix botch in changes of 19 Jan. 1994 that broke entry points with +multi-dimensional array arguments that did not appear in the subprogram +argument list and whose leading dimensions depend on arguments. + +Mon Feb 7 09:24:30 EST 1994 + Remove artifact in "fc" script that caused -O to be ignored: + 87c87 + < # lcc ignores -O... + --- + > CFLAGS="$CFLAGS $O" + +Sun Feb 20 17:04:58 EST 1994 + Fix bugs reading .P files for routines with arguments of type +INTEGER*1, INTEGER*8, LOGICAL*2. + Fix glitch in reporting inconsistent arguments for routines involving +character arguments: "arg n" had n too large by the number of +character arguments. + +Tue Feb 22 20:50:08 EST 1994 + Trivial changes to data.c format.c main.c niceprintf.c output.h and +sysdep.h (consistency improvements). + libI77: lread.c: check for NULL return from realloc. + +Fri Feb 25 23:56:08 EST 1994 + output.c, sysdep.h: arrange for -DUSE_DTOA to use dtoa.c and g_fmt.c +for correctly rounded decimal values on IEEE-arithmetic machines +(plus machines with VAX and IBM-mainframe arithmetic). These +routines are available from netlib's fp directory. + msdos/f2cx.exe.Z and msdos/f2c.exe.Z updated (ftp access only); the +former uses -DUSE_DTOA to keep 12 from printing as 12.000000000000001. + vax.c: fix wrong arguments to badtag and frchain introduced +28 Nov. 1993. + Source for f2c converted to ANSI/ISO format, with the K&R format +available by compilation with -DKR_headers . + Arrange for (double precision expression) relop (single precision +constant) to retain the single-precision nature of the constant. +Example: + double precision t + if (t .eq. 0.3) ... + +Mon Feb 28 11:40:24 EST 1994 + README updated to reflect a modification just made to netlib's +"dtoa.c from fp": +96a97,105 +> Also add the rule +> +> dtoa.o: dtoa.c +> $(CC) -c $(CFLAGS) -DMALLOC=ckalloc -DIEEE... dtoa.c +> +> (without the initial tab) to the makefile, where IEEE... is one of +> IEEE_MC68k, IEEE_8087, VAX, or IBM, depending on your machine's +> arithmetic. See the comments near the start of dtoa.c. +> + +Sat Mar 5 09:41:52 EST 1994 + Complain about functions with the name of a previously declared +common block (which is illegal). + New option -d specifies the directory for output .c and .P files; +f2c.1 and f2c.1t updated. The former undocumented debug option -dnnn +is now -Dnnn. + +Thu Mar 10 10:21:44 EST 1994 + libf77: add #undef min and #undef max lines to s_paus.c s_stop.c +and system_.c; Version.c not changed. + libi77: add -DPad_UDread lines to uio.c and explanation to README: + Some buggy Fortran programs use unformatted direct I/O to write + an incomplete record and later read more from that record than + they have written. For records other than the last, the unwritten + portion of the record reads as binary zeros. The last record is + a special case: attempting to read more from it than was written + gives end-of-file -- which may help one find a bug. Some other + Fortran I/O libraries treat the last record no differently than + others and thus give no help in finding the bug of reading more + than was written. If you wish to have this behavior, compile + uio.c with -DPad_UDread . +Version.c not changed. + +Tue Mar 29 17:27:54 EST 1994 + Adjust make_param so dimensions involving min, max, and other +complicated constant expressions do not provoke error messages +about adjustable dimensions on non-arguments. + Fix botch introduced 19 Jan 1994: "adjustable dimension on non- +argument" messages could cause some things to be freed twice. + +Tue May 10 07:55:12 EDT 1994 + Trivial changes to exec.c, p1output.c, parse_args.c, proc.c, +and putpcc.c: change arguments from + type foo[] +to + type *foo +for consistency with defs.h. For most compilers, this makes no +difference. + +Thu Jun 2 12:18:18 EDT 1994 + Fix bug in handling FORMAT statements that have adjacent character +(or Hollerith) strings: an extraneous \002 appeared between the +strings. + libf77: under -DNO_ONEXIT, arrange for f_exit to be called just +once; previously, upon abnormal termination (including stop statements), +it was called twice. + +Mon Jun 6 15:52:57 EDT 1994 + libf77: Avoid references to SIGABRT and SIGIOT if neither is defined; +Version.c not changed. + libi77: Add cast to definition of errfl() in fio.h; this only matters +on systems with sizeof(int) < sizeof(long). Under -DNON_UNIX_STDIO, +use binary mode for direct formatted files (to avoid any confusion +connected with \n characters). + +Fri Jun 10 16:47:31 EDT 1994 + Fix bug under -A in handling unreferenced (and undeclared) +external arguments in subroutines with multiple entry points. Example: + subroutine m(fcn,futil) + external fcn,futil + call fcn + entry mintio(i1) ! (D_fp)0 rather than (U_fp)0 for futil + end + +Wed Jun 15 10:38:14 EDT 1994 + Allow char(constant expression) function in parameter declarations. +(This was probably broken in the changes of 29 March 1994.) + +Fri Jul 1 23:54:00 EDT 1994 + Minor adjustments to makefile (rule for f2c.1 commented out) and +sysdep.h (#undef KR_headers if __STDC__ is #defined, and base test +for ANSI_Libraries and ANSI_Prototypes on KR_headers rather than +__STDC__); version.c touched but not changed. + libi77: adjust fp.h so local.h is only needed under -DV10; +Version.c not changed. + +Tue Jul 5 03:05:46 EDT 1994 + Fix segmentation fault in + subroutine foo(a,b,k) + data i/1/ + double precision a(k,1) ! sequence error: must precede data + b = a(i,1) + end + libi77: Fix bug (introduced 6 June 1994?) in reopening files under +NON_UNIX_STDIO. + Fix some error messages caused by illegal Fortran. Examples: +* 1. + x(i) = 0 !Missing declaration for array x + call f(x) !Said Impossible storage class 8 in routine mkaddr + end !Now says invalid use of statement function x +* 2. + f = g !No declaration for g; by default it's a real variable + call g !Said invalid class code 2 for function g + end !Now says g cannot be called +* 3. + intrinsic foo !Invalid intrinsic name + a = foo(b) !Said intrcall: bad intrgroup 0 + end !Now just complains about line 1 + +Tue Jul 5 11:14:26 EDT 1994 + Fix glitch in handling erroneous statement function declarations. +Example: + a(j(i) - i) = a(j(i) - i) + 1 ! bad statement function + call foo(a(3)) ! Said Impossible type 0 in routine mktmpn + end ! Now warns that i and j are not used + +Wed Jul 6 17:31:25 EDT 1994 + Tweak test for statement functions that (illegally) call themselves; +f2c will now proceed to check for other errors, rather than bailing +out at the first recursive statement function reference. + Warn about but retain divisions by 0 (instead of calling them +"compiler errors" and quiting). On IEEE machines, this permits + double precision nan, ninf, pinf + nan = 0.d0/0.d0 + pinf = 1.d0/0.d0 + ninf = -1.d0/0.d0 + write(*,*) 'nan, pinf, ninf = ', nan, pinf, ninf + end +to print + nan, pinf, ninf = NaN Infinity -Infinity + libi77: wref.c: protect with #ifdef GOOD_SPRINTF_EXPONENT an +optimization that requires exponents to have 2 digits when 2 digits +suffice. lwrite.c wsfe.c (list and formatted external output): +omit ' ' carriage-control when compiled with -DOMIT_BLANK_CC . +Off-by-one bug fixed in character count for list output of character +strings. Omit '.' in list-directed printing of Nan, Infinity. + +Mon Jul 11 13:05:33 EDT 1994 + src/gram.c updated. + +Tue Jul 12 10:24:42 EDT 1994 + libi77: wrtfmt.c: under G11.4, write 0. as " .0000 " rather +than " .0000E+00". + +Thu Jul 14 17:55:46 EDT 1994 + Fix glitch in changes of 6 July 1994 that could cause erroneous +"division by zero" warnings (or worse). Example: + subroutine foo(a,b) + y = b + a = a / y ! erroneous warning of division by zero + end + +Mon Aug 1 16:45:17 EDT 1994 + libi77: lread.c rsne.c: for benefit of systems with a buggy stdio.h, +declare ungetc when neither KR_headers nor ungetc is #defined. +Version.c not changed. + +Wed Aug 3 01:53:00 EDT 1994 + libi77: lwrite.c (list output): do not insert a newline when +appending an oversize item to an empty line. + +Mon Aug 8 00:51:01 EDT 1994 + Fix bug (introduced 3 Feb. 1993) that, under -i2, kept LOGICAL*2 +variables from appearing in INQUIRE statements. Under -I2, allow +LOGICAL*4 variables to appear in INQUIRE. Fix intrinsic function +LEN so it returns a short value under -i2, a long value otherwise. + exec.c: fix obscure memory fault possible with bizarre (and highly +erroneous) DO-loop syntax. + +Fri Aug 12 10:45:57 EDT 1994 + libi77: fix glitch that kept ERR= (in list- or format-directed input) +from working after a NAMELIST READ. + +Thu Aug 25 13:58:26 EDT 1994 + Suppress -s when -C is specified. + Give full pathname (netlib@research.att.com) for netlib in readme and +src/README. + +Wed Sep 7 22:13:20 EDT 1994 + libi77: typesize.c: adjust to allow types LOGICAL*1, LOGICAL*2, +INTEGER*1, and (under -DAllow_TYQUAD) INTEGER*8 in NAMELISTs. + +Fri Sep 16 17:50:18 EDT 1994 + Change name adjustment for reserved words: instead of just appending +"_" (a single underscore), append "_a_" to local variable names to avoid +trouble when a common block is named a reserved word and the same +reserved word is also a local variable name. Example: + common /const/ a,b,c + real const(3) + equivalence (const(1),a) + a = 1.234 + end + Arrange for ichar() to treat characters as unsigned. + libf77: s_cmp.c: treat characters as unsigned in comparisons. +These changes for unsignedness only matter for strings that contain +non-ASCII characters. Now ichar() should always be >= 0. + +Sat Sep 17 11:19:32 EDT 1994 + fc: set rc=$? before exit (to get exit code right in trap code). + +Mon Sep 19 17:49:43 EDT 1994 + libf77: s_paus.c: flush stderr after PAUSE; add #ifdef MSDOS stuff. + libi77: README: point out general need for -DMSDOS under MS-DOS. + +Tue Sep 20 11:42:30 EDT 1994 + Fix bug in comparing identically named common blocks, in which +all components have the same names and types, but at least one is +dimensioned (1) and the other is not dimensioned. Example: + subroutine foo + common /ab/ a + a=1. !!! translated correctly to ab_1.a = (float)1.; + end + subroutine goo + common /ab/ a(1) + a(1)=2. !!! translated erroneously to ab_1.a[0] = (float)2. + end + +Tue Sep 27 23:47:34 EDT 1994 + Fix bug introduced 16 Sept. 1994: don't add _a_ to C keywords +used as external names. In fact, return to earlier behavior of +appending __ to C keywords unless they are used as external names, +in which case they get just one underscore appended. + Adjust constant handling so integer and logical PARAMETERs retain +type information, particularly under -I2. Example: + SUBROUTINE FOO + INTEGER I + INTEGER*1 I1 + INTEGER*2 I2 + INTEGER*4 I4 + LOGICAL L + LOGICAL*1 L1 + LOGICAL*2 L2 + LOGICAL*4 L4 + PARAMETER (L=.FALSE., L1=.FALSE., L2=.FALSE., L4=.FALSE.) + PARAMETER (I=0,I1=0,I2=0,I4=0) + CALL DUMMY(I, I1, I2, I4, L, L1, L2, L4) + END + f2c.1t: Change f\^2c to f2c (omit half-narrow space) in line following +".SH NAME" for benefit of systems that cannot cope with troff commands +in this context. + +Wed Sep 28 12:45:19 EDT 1994 + libf77: s_cmp.c fix glitch in -DKR_headers version introduced +12 days ago. + +Thu Oct 6 09:46:53 EDT 1994 + libi77: util.c: omit f__mvgbt (which is never used). + f2c.h: change "long" to "long int" to facilitate the adjustments +by means of sed described above. Comment out unused typedef of Long. + +Fri Oct 21 18:02:24 EDT 1994 + libf77: add s_catow.c and adjust README to point out that changing +"s_cat.o" to "s_catow.o" in the makefile will permit the target of a +concatenation to appear on its right-hand side (contrary to the +Fortran 77 Standard and at the cost of some run-time efficiency). + +Wed Nov 2 00:03:58 EST 1994 + Adjust -g output to contain only one #line line per statement, +inserting \ before the \n ending lines broken because of their +length [this insertion was recanted 10 Dec. 1994]. This change +accommodates an idiocy in the ANSI/ISO C standard, which leaves +undefined the behavior of #line lines that occur within the arguments +to a macro call. + +Wed Nov 2 14:44:27 EST 1994 + libi77: under compilation with -DALWAYS_FLUSH, flush buffers at +the end of each write statement, and test (via the return from +fflush) for write failures, which can be caught with an ERR= +specifier in the write statement. This extra flushing slows +execution, but can abort execution or alter the flow of control +when a disk fills up. + f2c/src/io.c: Add ERR= test to e_wsle invocation (end of +list-directed external output) to catch write failures when libI77 +is compiled with -DALWAYS_FLUSH. + +Thu Nov 3 10:59:13 EST 1994 + Fix bug in handling dimensions involving certain intrinsic +functions of constant expressions: the expressions, rather than +pointers to them, were passed. Example: + subroutine subtest(n,x) + real x(2**n,n) ! pow_ii(2,n) was called; now it's pow_ii(&c__2,n) + x(2,2)=3. + end + +Tue Nov 8 23:56:30 EST 1994 + malloc.c: remove assumption that only malloc calls sbrk. This +appears to make malloc.c useful on RS6000 systems. + +Sun Nov 13 13:09:38 EST 1994 + Turn off constant folding of integers used in floating-point +expressions, so the assignment in + subroutine foo(x) + double precision x + x = x*1000000*500000 + end +is rendered as + *x = *x * 1000000 * 500000; +rather than as + *x *= 1783793664; + +Sat Dec 10 16:31:40 EST 1994 + Supply a better error message (than "Impossible type 14") for + subroutine foo + foo = 3 + end + Under -g, convey name of included files to #line lines. + Recant insertion of \ introduced (under -g) 2 Nov. 1994. + +Thu Dec 15 14:33:55 EST 1994 + New command-line option -Idir specifies directories in which to +look for non-absolute include files (after looking in the directory +of the current input file). There can be several -Idir options, each +specifying one directory. All -Idir options are considered, from +left to right, until a suitably named file is found. The -I2 and -I4 +command-line options have precedence, so directories named 2 or 4 +must be spelled by some circumlocation, such as -I./2 . + f2c.ps updated to mention the new -Idir option, correct a typo, +and bring the man page at the end up to date. + lex.c: fix bug in reading line numbers in #line lines. + fc updated to pass -Idir options to f2c. + +Thu Dec 29 09:48:03 EST 1994 + Fix bug (e.g., addressing fault) in diagnosing inconsistency in +the type of function eta in the following example: + function foo(c1,c2) + double complex foo,c1,c2 + double precision eta + foo = eta(c1,c2) + end + function eta(c1,c2) + double complex eta,c1,c2 + eta = c1*c2 + end + +Mon Jan 2 13:27:26 EST 1995 + Retain casts for SNGL (or FLOAT) that were erroneously optimized +away. Example: + subroutine foo(a,b) + double precision a,b + a = float(b) ! now rendered as *a = (real) (*b); + end + Use float (rather than double) temporaries in certain expressions +of type complex. Example: the temporary for sngl(b) in + complex a + double precision b + a = sngl(b) - (3.,4.) +is now of type float. + +Fri Jan 6 00:00:27 EST 1995 + Adjust intrinsic function cmplx to act as dcmplx (returning +double complex rather than complex) if either of its args is of +type double precision. The double temporaries used prior to 2 Jan. +1995 previously gave it this same behavior. + +Thu Jan 12 12:31:35 EST 1995 + Adjust -krd to use double temporaries in some calculations of +type complex. + libf77: pow_[dhiqrz][hiq].c: adjust x**i to work on machines +that sign-extend right shifts when i is the most negative integer. + +Wed Jan 25 00:14:42 EST 1995 + Fix memory fault in handling overlapping initializations in + block data + common /zot/ d + double precision d(3) + character*6 v(4) + real r(2) + equivalence (d(3),r(1)), (d(1),v(1)) + data v/'abcdef', 'ghijkl', 'mnopqr', 'stuvwx'/ + data r/4.,5./ + end + names.c: add "far", "huge", "near" to c_keywords (causing them +to have __ appended when used as local variables). + libf77: add s_copyow.c, an alternative to s_copy.c for handling +(illegal) character assignments where the right- and left-hand +sides overlap, as in a(2:4) = a(1:3). + +Thu Jan 26 14:21:19 EST 1995 + libf77: roll s_catow.c and s_copyow.c into s_cat.c and s_copy.c, +respectively, allowing the left-hand side of a character assignment +to appear on its right-hand side unless s_cat.c and s_copy.c are +compiled with -DNO_OVERWRITE (which is a bit more efficient). +Fortran 77 forbids the left-hand side from participating in the +right-hand side (of a character assignment), but Fortran 90 allows it. + libi77: wref.c: fix glitch in printing the exponent of 0 when +GOOD_SPRINTF_EXPONENT is not #defined. + +Fri Jan 27 12:25:41 EST 1995 + Under -C++ -ec (or -C++ -e1c), surround struct declarations with + #ifdef __cplusplus + extern "C" { + #endif +and + #ifdef __cplusplus + } + #endif +(This isn't needed with cfront, but apparently is necessary with +some other C++ compilers.) + libf77: minor tweak to s_copy.c: copy forward whenever possible +(for better cache behavior). + +Wed Feb 1 10:26:12 EST 1995 + Complain about parameter statements that assign values to dummy +arguments, as in + subroutine foo(x) + parameter(x = 3.4) + end + +Sat Feb 4 20:22:02 EST 1995 + fc: omit "lib=/lib/num/lib.lo". + +Wed Feb 8 08:41:14 EST 1995 + Minor changes to exec.c, putpcc.c to avoid "bad tag" or "error +in frexpr" with certain invalid Fortran. + +Sat Feb 11 08:57:39 EST 1995 + Complain about integer overflows, both in simplifying integer +expressions, and in converting integers from decimal to binary. + Fix a memory fault in putcx1() associated with invalid input. + +Thu Feb 23 11:20:59 EST 1995 + Omit MAXTOKENLEN; realloc token if necessary (to handle very long +strings). + +Fri Feb 24 11:02:00 EST 1995 + libi77: iio.c: z_getc: insert (unsigned char *) to allow internal +reading of characters with high-bit set (on machines that sign-extend +characters). + +Tue Mar 14 18:22:42 EST 1995 + Fix glitch (in io.c) in handling 0-length strings in format +statements, as in + write(*,10) + 10 format(' ab','','cd') + libi77: lread.c and rsfe.c: adjust s_rsle and s_rsfe to check for +end-of-file (to prevent infinite loops with empty read statements). + +Wed Mar 22 10:01:46 EST 1995 + f2c.ps: adjust discussion of -P on p. 7 to reflect a change made +3 Feb. 1993: -P no longer implies -A. + +Fri Apr 21 18:35:00 EDT 1995 + fc script: remove absolute paths (since PATH specifies only standard +places). On most systems, it's still necessary to adjust the PATH +assignment at the start of fc to fit the local conventions. + +Fri May 26 10:03:17 EDT 1995 + fc script: add recognition of -P and .P files. + libi77: iio.c: z_wnew: fix bug in handling T format items in internal +writes whose last item is written to an earlier position than some +previous item. + +Wed May 31 11:39:48 EDT 1995 + libf77: added subroutine exit(rc) (with integer return code rc), +which works like a stop statement but supplies rc as the program's +return code. + +Fri Jun 2 11:56:50 EDT 1995 + Fix memory fault in + parameter (x=2.) + data x /2./ + end +This now elicits two error messages; the second ("too many +initializers"), though not desirable, seems hard to eliminate +without considerable hassle. + +Mon Jul 17 23:24:20 EDT 1995 + Fix botch in simplifying constants in certain complex +expressions. Example: + subroutine foo(s,z) + double complex z + double precision s, M, P + parameter ( M = 100.d0, P = 2.d0 ) + z = M * M / s * dcmplx (1.d0, P/M) +*** The imaginary part of z was miscomputed *** + end + Under -ext, complain about nonintegral dimensions. + +Fri Jul 21 11:18:36 EDT 1995 + Fix glitch on line 159 of init.c: change + "(shortlogical *)0)", +to + "(shortlogical *)0", +This affects multiple entry points when some but not all have +arguments of type logical*2. + libi77: adjust lwrite.c, wref.c, wrtfmt.c so compiling with +-DWANT_LEAD_0 causes formatted writes of floating-point numbers of +magnitude < 1 to have an explicit 0 before the decimal point (if the +field-width permits it). Note that the Fortran 77 Standard leaves it +up to the implementation whether to supply these superfluous zeros. + +Tue Aug 1 09:25:56 EDT 1995 + Permit real (or double precision) parameters in dimension expressions. + +Mon Aug 7 08:04:00 EDT 1995 + Append "_eqv" rather than just "_" to names that that appear in +EQUIVALENCE statements as well as structs in f2c.h (to avoid a +conflict when these names also name common blocks). + +Tue Aug 8 12:49:02 EDT 1995 + Modify yesterday's change: merge st_fields with c_keywords, to +cope with equivalences introduced to permit initializing numeric +variables with character data. DATA statements causing these +equivalences can appear after executable statements, so the only +safe course is to rename all local variable with names in the +former st_fields list. This has the unfortunate side effect that +the common local variable "i" will henceforth be renamed "i__". + +Wed Aug 30 00:19:32 EDT 1995 + libf77: add F77_aloc, now used in s_cat and system_ (to allocate +memory and check for failure in so doing). + libi77: improve MSDOS logic in backspace.c. + +Wed Sep 6 09:06:19 EDT 1995 + libf77: Fix return type of system_ (integer) under -DKR_headers. + libi77: Move some f_init calls around for people who do not use +libF77's main(); now open and namelist read statements that are the +first I/O statements executed should work right in that context. +Adjust namelist input to treat a subscripted name whose subscripts do +not involve colons similarly to the name without a subscript: accept +several values, stored in successive elements starting at the +indicated subscript. Adjust namelist output to quote character +strings (avoiding confusion with arrays of character strings). + +Thu Sep 7 00:36:04 EDT 1995 + Fix glitch in integer*8 exponentiation function: it's pow_qq, not +pow_qi. + libi77: fix some bugs with -DAllow_TYQUAD (for integer*8); when +looking for the &name that starts NAMELIST input, treat lines whose +first nonblank character is something other than &, $, or ? as +comment lines (i.e., ignore them), unless rsne.c is compiled with +-DNo_Namelist_Comments. + +Thu Sep 7 09:05:40 EDT 1995 + libi77: rdfmt.c: one more tweak for -DAllow_TYQUAD. + +Tue Sep 19 00:03:02 EDT 1995 + Adjust handling of floating-point subscript bounds (a questionable +f2c extension) so subscripts in the generated C are of integral type. + Move #define of roundup to proc.c (where its use is commented out); +version.c left at 19950918. + +Wed Sep 20 17:24:19 EDT 1995 + Fix bug in handling ichar() under -h. + +Thu Oct 5 07:52:56 EDT 1995 + libi77: wrtfmt.c: fix bug with t editing (f__cursor was not always +zeroed in mv_cur). + +Tue Oct 10 10:47:54 EDT 1995 + Under -ext, warn about X**-Y and X**+Y. Following the original f77, +f2c treats these as X**(-Y) and X**(+Y), respectively. (They are not +allowed by the official Fortran 77 Standard.) Some Fortran compilers +give a bizarre interpretation to larger contexts, making multiplication +noncommutative: they treat X**-Y*Z as X**(-Y*Z) rather than X**(-Y)*Z, +which, following the rules of Fortran 77, is the same as (X**(-Y))*Z. + +Wed Oct 11 13:27:05 EDT 1995 + libi77: move defs of f__hiwater, f__svic, f__icptr from wrtfmt.c +to err.c. This should work around a problem with buggy loaders and +sometimes leads to smaller executable programs. + +Sat Oct 21 23:54:22 EDT 1995 + Under -h, fix bug in the treatment of ichar('0') in arithmetic +expressions. + Demote to -dneg (a new command-line option not mentioned in the +man page) imitation of the original f77's treatment of unary minus +applied to a REAL operand (yielding a DOUBLE PRECISION result). +Previously this imitation (which was present for debugging) occurred +under (the default) -!R. It is still suppressed by -R. + +Tue Nov 7 23:52:57 EST 1995 + Adjust assigned GOTOs to honor SAVE declarations. + Add comments about ranlib to lib[FI]77/README and makefile. + +Tue Dec 19 22:54:06 EST 1995 + libf77: s_cat.c: fix bug when 2nd or later arg overlaps lhs. + +Tue Jan 2 17:54:00 EST 1996 + libi77: rdfmt.c: move #include "ctype.h" up before "stdlib.h"; no +change to Version.c. + +Sun Feb 25 22:20:20 EST 1996 + Adjust expr.c to permit raising the integer constants 1 and -1 to +negative constant integral powers. + Avoid faulting when -T and -d are not followed by a directory name +(immediately, without intervening spaces). + +Wed Feb 28 12:49:01 EST 1996 + Fix a glitch in handling complex parameters assigned a "wrong" type. +Example: + complex d, z + parameter(z = (0d0,0d0)) + data d/z/ ! elicited "non-constant initializer" + call foo(d) + end + +Thu Feb 29 00:53:12 EST 1996 + Fix bug in handling character parameters assigned a char() value. +Example: + character*2 b,c + character*1 esc + parameter(esc = char(27)) + integer i + data (b(i:i),i=1,2)/esc,'a'/ + data (c(i:i),i=1,2)/esc,'b'/ ! memory fault + call foo(b,c) + end + +Fri Mar 1 23:44:51 EST 1996 + Fix glitch in evaluating .EQ. and .NE. when both operands are +logical constants (.TRUE. or .FALSE.). + +Fri Mar 15 17:29:54 EST 1996 + libi77: lread.c, rsfe.c: honor END= in READ stmts with empty iolist. + +Tue Mar 19 23:08:32 EST 1996 + lex.c: arrange for a "statement" consisting of a single short bogus +keyword to elicit an error message showing the whole keyword. The +error message formerly omitted the last letter of the bad keyword. + libf77: s_cat.c: supply missing break after overlap detection. + +Mon May 13 23:35:26 EDT 1996 + Recognize Fortran 90's /= as a synonym for .NE.. (<> remains a +synonym for .NE..) + Emit an empty int function of no arguments to supply an external +name to named block data subprograms (so they can be called somewhere +to force them to be loaded from a library). + Fix bug (memory fault) in handling the following illegal Fortran: + parameter(i=1) + equivalence(i,j) + end + Treat cdabs, cdcos, cdexp, cdlog, cdsin, and cdsqrt as synonyms for +the double complex intrinsics zabs, zcos, zexp, zlog, zsin, and zsqrt, +respectively, unless -cd is specified. + Recognize the Fortran 90 bit-manipulation intrinsics btest, iand, +ibclr, ibits, ibset, ieor, ior, ishft, and ishftc, unless -i90 is +specified. Note that iand, ieor, and ior are thus now synonyms for +"and", "xor", and "or", respectively. + Add three macros (bit_test, bit_clear, bit_set) to f2c.h for use +with btest, ibclr, and ibset, respectively. Add new functions +[lq]bit_bits, [lq]bit_shift, and [lq]_bit_cshift to libF77 for +use with ibits, ishft, and ishftc, respectively. + Add integer function ftell(unit) (returning -1 on error) and +subroutine fseek(unit, offset, whence, *) to libI77 (with branch to +label * on error). + +Tue May 14 23:21:12 EDT 1996 + Fix glitch (possible memory fault, or worse) in handling multiple +entry points with names over 28 characters long. + +Mon Jun 10 01:20:16 EDT 1996 + Update netlib E-mail and ftp addresses in f2c/readme and +f2c/src/readme (which are different files) -- to reflect the upcoming +breakup of AT&T. + libf77: trivial tweaks to F77_aloc.c and system_.c; Version.c not +changed. + libi77: Adjust rsli.c and lread.c so internal list input with too +few items in the input string will honor end= . + +Mon Jun 10 22:59:57 EDT 1996 + Add Bits_per_Byte to sysdep.h and adjust definition of Table_size +to depend on Bits_per_Byte (forcing Table_size to be a power of 2); in +lex.c, change "comstart[c & 0xfff]" to "comstart[c & (Table_size-1)]" +to avoid an out-of-range subscript on end-of-file. + +Wed Jun 12 00:24:28 EDT 1996 + Fix bug in output.c (dereferencing a freed pointer) revealed in + print * !np in out_call in output.c clobbered by free + end !during out_expr. + +Wed Jun 19 08:12:47 EDT 1996 + f2c.h: add types uinteger, ulongint (for libF77); add qbit_clear +and qbit_set macros (in a commented-out section) for integer*8. + For integer*8, use qbit_clear and qbit_set for ibclr and ibset. + libf77: add casts to unsigned in [lq]bitshft.c. + +Thu Jun 20 13:30:43 EDT 1996 + Complain at character*(*) in common (rather than faulting). + Fix bug in recognizing hex constants that start with "16#" (e.g., +16#1234abcd, which is a synonym for z'1234abcd'). + Fix bugs in constant folding of expressions involving btest, ibclr, +and ibset. + Fix bug in constant folding of rshift(16#80000000, -31) (on a 32-bit +machine; more generally, the bug was in constant folding of +rshift(ibset(0,NBITS-1), 1-NBITS) when f2c runs on a machine with +long ints having NBITS bits. + +Mon Jun 24 07:58:53 EDT 1996 + Adjust struct Literal and newlabel() function to accommodate huge +source files (with more than 32767 newlabel() invocations). + Omit .c file when the .f file has a missing final end statement. + +Wed Jun 26 14:00:02 EDT 1996 + libi77: Add discussion of MXUNIT (highest allowed Fortran unit number) +to libI77/README. + +Fri Jun 28 14:16:11 EDT 1996 + Fix glitch with -onetrip: the temporary variable used for nonconstant +initial loop variable values was recycled too soon. Example: + do i = j+1, k + call foo(i+1) ! temp for j+1 was reused here + enddo + end + +Tue Jul 2 16:11:27 EDT 1996 + formatdata.c: add a 0 to the end of the basetype array (for TYBLANK) +(an omission that was harmless on most machines). + expr.c: fix a dereference of NULL that was only possible with buggy +input, such as + subroutine $sub(s) ! the '$' is erroneous + character s*(*) + s(1:) = ' ' + end + +Sat Jul 6 00:44:56 EDT 1996 + Fix glitch in the intrinsic "real" function when applied to a +complex (or double complex) variable and passed as an argument to +some intrinsic functions. Example: + complex a + b = sqrt(a) + end + Fix glitch (only visible if you do not use f2c's malloc and the +malloc you do use is defective in the sense that malloc(0) returns 0) +in handling include files that end with another include (perhaps +followed by comments). + Fix glitch with character*(*) arguments named "h" and "i" when +the body of the subroutine invokes the intrinsic LEN function. + Arrange that after a previous "f2c -P foo.f" has produced foo.P, +running "f2c foo.P foo.f" will produce valid C when foo.f contains + call sub('1234') + end + subroutine sub(msg) + end +Specifically, the length argument in "call sub" is now suppressed. +With or without foo.P, it is also now suppressed when the order of +subprograms in file foo.f is reversed: + subroutine sub(msg) + end + call sub('1234') + end + Adjust copyright notices to reflect AT&T breakup. + +Wed Jul 10 09:25:49 EDT 1996 + Fix bug (possible memory fault) in handling erroneously placed +and inconsistent declarations. Example that faulted: + character*1 w(8) + call foo(w) + end + subroutine foo(m) + data h /0.5/ + integer m(2) ! should be before data + end + Fix bug (possible fault) in handling illegal "if" constructions. +Example (that faulted): + subroutine foo(i,j) + if (i) then ! bug: i is integer, not logical + else if (j) then ! bug: j is integer, not logical + endif + end + Fix glitch with character*(*) argument named "ret_len" to a +character*(*) function. + +Wed Jul 10 23:04:16 EDT 1996 + Fix more glitches in the intrinsic "real" function when applied to a +complex (or double complex) variable and passed as an argument to +some intrinsic functions. Example: + complex a, b + r = sqrt(real(conjg(a))) + sqrt(real(a*b)) + end + +Thu Jul 11 17:27:16 EDT 1996 + Fix a memory fault associated with complicated, illegal input. +Example: + subroutine goo + character a + call foo(a) ! inconsistent with subsequent def and call + end + subroutine foo(a) + end + call foo(a) + end + +Wed Jul 17 19:18:28 EDT 1996 + Fix yet another case of intrinsic "real" applied to a complex +argument. Example: + complex a(3) + x = sqrt(real(a(2))) ! gave error message about bad tag + end + +Mon Aug 26 11:28:57 EDT 1996 + Tweak sysdep.c for non-Unix systems in which process ID's can be +over 5 digits long. + +Tue Aug 27 08:31:32 EDT 1996 + Adjust the ishft intrinsic to use unsigned right shifts. (Previously, +a negative constant second operand resulted in a possibly signed shift.) + +Thu Sep 12 14:04:07 EDT 1996 + equiv.c: fix glitch with -DKR_headers. + libi77: fmtlib.c: fix bug in printing the most negative integer. + +Fri Sep 13 08:54:40 EDT 1996 + Diagnose some illegal appearances of substring notation. + +Tue Sep 17 17:48:09 EDT 1996 + Fix fault in handling some complex parameters. Example: + subroutine foo(a) + double complex a, b + parameter(b = (0,1)) + a = b ! f2c faulted here + end + +Thu Sep 26 07:47:10 EDT 1996 + libi77: fmt.h: for formatted writes of negative integer*1 values, +make ic signed on ANSI systems. If formatted writes of integer*1 +values trouble you when using a K&R C compiler, switch to an ANSI +compiler or use a compiler flag that makes characters signed. + +Tue Oct 1 14:41:36 EDT 1996 + Give a better error message when dummy arguments appear in data +statements. + +Thu Oct 17 13:37:22 EDT 1996 + Fix bug in typechecking arguments to character and complex (or +double complex) functions; the bug could cause length arguments +for character arguments to be omitted on invocations appearing +textually after the first invocation. For example, in + subroutine foo + character c + complex zot + call goo(zot(c), zot(c)) + end +the length was omitted from the second invocation of zot, and +there was an erroneous error message about inconsistent calling +sequences. + +Wed Dec 4 13:59:14 EST 1996 + Fix bug revealed by + subroutine test(cdum,rdum) + complex cdum + rdum=cos(real(cdum)) ! "Unexpected tag 3 in opconv_fudge" + end + Fix glitch in parsing "DO 10 D0 = 1, 10". + Fix glitch in parsing + real*8 x + real*8 x ! erroneous "incompatible type" message + call foo(x) + end + +Mon Dec 9 23:15:02 EST 1996 + Fix glitch in parameter adjustments for arrays whose lower +bound depends on a scalar argument. Example: + subroutine bug(p,z,m,n) + integer z(*),m,n + double precision p(z(m):z(m) + n) ! p_offset botched + call foo(p(0), p(n)) + end + libi77: complain about non-positive rec= in direct read and write +statements. + libf77: trivial adjustments; Version.c not changed. + +Wed Feb 12 00:18:03 EST 1997 + output.c: fix (seldom problematic) glitch in out_call: put parens +around the ... in a test of the form "if (q->tag == TADDR && ...)". + vax.c: fix bug revealed in the "psi_offset =" assignment in the +following example: + subroutine foo(psi,m) + integer z(100),m + common /a/ z + double precision psi(z(m):z(m) + 10) + call foo(m+1, psi(0),psi(10)) + end + +Mon Feb 24 23:44:54 EST 1997 + For consistency with f2c's current treatment of adjacent character +strings in FORMAT statements, recognize a Hollerith string following +a string (and merge adjacent strings in FORMAT statements). + +Wed Feb 26 13:41:11 EST 1997 + New libf2c.zip, a combination of the libf77 and libi77 bundles (and +available only by ftp). + libf77: adjust functions with a complex output argument to permit +aliasing it with input arguments. (For now, at least, this is just +for possible benefit of g77.) + libi77: tweak to ftell_.c for systems with strange definitions of +SEEK_SET, etc. + +Tue Apr 8 20:57:08 EDT 1997 + libf77: [cz]_div.c: tweaks invisible on most systems (that may +improve things slightly with optimized compilation on systems that use +gratuitous extra precision). + libi77: fmt.c: adjust to complain at missing numbers in formats +(but still treat missing ".nnn" as ".0"). + +Fri Apr 11 14:05:57 EDT 1997 + libi77: err.c: attempt to make stderr line buffered rather than +fully buffered. (Buffering is needed for format items T and TR.) + +Thu Apr 17 22:42:43 EDT 1997 + libf77: add F77_aloc.o to makefile (and makefile.u in libf2c.zip). + +Fri Apr 25 19:32:09 EDT 1997 + libf77: add [de]time_.c (which may give trouble on some systems). + +Tue May 27 09:18:52 EDT 1997 + libi77: ftell_.c: fix typo that caused the third argument to be +treated as 2 on some systems. + +Mon Jun 9 00:04:37 EDT 1997 + libi77 (and libf2c.zip): adjust include order in err.c lread.c wref.c +rdfmt.c to include fmt.h (etc.) after system includes. Version.c not +changed. + +Mon Jul 21 16:04:54 EDT 1997 + proc.c: fix glitch in logic for "nonpositive dimension" message. + libi77: inquire.c: always include string.h (for possible use with +-DNON_UNIX_STDIO); Version.c not changed. + +Thu Jul 24 17:11:23 EDT 1997 + Tweak "Notice" to reflect the AT&T breakup -- we missed it when +updating the copyright notices in the source files last summer. + Adjust src/makefile so malloc.o is not used by default, but can +be specified with "make MALLOC=malloc.o". + Add comments to src/README about the "CRAY" T3E. + +Tue Aug 5 14:53:25 EDT 1997 + Add definition of calloc to malloc.c; this makes f2c's malloc +work on some systems where trouble hitherto arose because references +to calloc brought in the system's malloc. (On sensible systems, +calloc is defined separately from malloc. To avoid confusion on +other systems, f2c/malloc.c now defines calloc.) + libi77: lread.c: adjust to accord with a change to the Fortran 8X +draft (in 1990 or 1991) that rescinded permission to elide quote marks +in namelist input of character data; to get the old behavior, compile +with F8X_NML_ELIDE_QUOTES #defined. wrtfmt.o: wrt_G: tweak to print +the right number of 0's for zero under G format. diff --git a/gcc/f/runtime/configure b/gcc/f/runtime/configure new file mode 100755 index 000000000000..dcc60b6e6568 --- /dev/null +++ b/gcc/f/runtime/configure @@ -0,0 +1,2048 @@ +#! /bin/sh + +# Guess values for system-dependent variables and create Makefiles. +# Generated automatically using autoconf version 2.12 +# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc. +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. + +# Defaults: +ac_help= +ac_default_prefix=/usr/local +# Any additions from configure.in: + +# Initialize some variables set by options. +# The variables have the same names as the options, with +# dashes changed to underlines. +build=NONE +cache_file=./config.cache +exec_prefix=NONE +host=NONE +no_create= +nonopt=NONE +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +target=NONE +verbose= +x_includes=NONE +x_libraries=NONE +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datadir='${prefix}/share' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +libdir='${exec_prefix}/lib' +includedir='${prefix}/include' +oldincludedir='/usr/include' +infodir='${prefix}/info' +mandir='${prefix}/man' + +# Initialize some other variables. +subdirs= +MFLAGS= MAKEFLAGS= +# Maximum number of lines to put in a shell here document. +ac_max_here_lines=12 + +ac_prev= +for ac_option +do + + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval "$ac_prev=\$ac_option" + ac_prev= + continue + fi + + case "$ac_option" in + -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; + *) ac_optarg= ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case "$ac_option" in + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir="$ac_optarg" ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build="$ac_optarg" ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file="$ac_optarg" ;; + + -datadir | --datadir | --datadi | --datad | --data | --dat | --da) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ + | --da=*) + datadir="$ac_optarg" ;; + + -disable-* | --disable-*) + ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + eval "enable_${ac_feature}=no" ;; + + -enable-* | --enable-*) + ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "enable_${ac_feature}='$ac_optarg'" ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix="$ac_optarg" ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he) + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat << EOF +Usage: configure [options] [host] +Options: [defaults in brackets after descriptions] +Configuration: + --cache-file=FILE cache test results in FILE + --help print this message + --no-create do not create output files + --quiet, --silent do not print \`checking...' messages + --version print the version of autoconf that created configure +Directory and file names: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [same as prefix] + --bindir=DIR user executables in DIR [EPREFIX/bin] + --sbindir=DIR system admin executables in DIR [EPREFIX/sbin] + --libexecdir=DIR program executables in DIR [EPREFIX/libexec] + --datadir=DIR read-only architecture-independent data in DIR + [PREFIX/share] + --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data in DIR + [PREFIX/com] + --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var] + --libdir=DIR object code libraries in DIR [EPREFIX/lib] + --includedir=DIR C header files in DIR [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include] + --infodir=DIR info documentation in DIR [PREFIX/info] + --mandir=DIR man documentation in DIR [PREFIX/man] + --srcdir=DIR find the sources in DIR [configure dir or ..] + --program-prefix=PREFIX prepend PREFIX to installed program names + --program-suffix=SUFFIX append SUFFIX to installed program names + --program-transform-name=PROGRAM + run sed PROGRAM on installed program names +EOF + cat << EOF +Host type: + --build=BUILD configure for building on BUILD [BUILD=HOST] + --host=HOST configure for HOST [guessed] + --target=TARGET configure for TARGET [TARGET=HOST] +Features and packages: + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --x-includes=DIR X include files are in DIR + --x-libraries=DIR X library files are in DIR +EOF + if test -n "$ac_help"; then + echo "--enable and --with options recognized:$ac_help" + fi + exit 0 ;; + + -host | --host | --hos | --ho) + ac_prev=host ;; + -host=* | --host=* | --hos=* | --ho=*) + host="$ac_optarg" ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir="$ac_optarg" ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir="$ac_optarg" ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir="$ac_optarg" ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir="$ac_optarg" ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst \ + | --locals | --local | --loca | --loc | --lo) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* \ + | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) + localstatedir="$ac_optarg" ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir="$ac_optarg" ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir="$ac_optarg" ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix="$ac_optarg" ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix="$ac_optarg" ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix="$ac_optarg" ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name="$ac_optarg" ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir="$ac_optarg" ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir="$ac_optarg" ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site="$ac_optarg" ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir="$ac_optarg" ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir="$ac_optarg" ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target="$ac_optarg" ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers) + echo "configure generated by autoconf version 2.12" + exit 0 ;; + + -with-* | --with-*) + ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "with_${ac_package}='$ac_optarg'" ;; + + -without-* | --without-*) + ac_package=`echo $ac_option|sed -e 's/-*without-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + eval "with_${ac_package}=no" ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes="$ac_optarg" ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries="$ac_optarg" ;; + + -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } + ;; + + *) + if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then + echo "configure: warning: $ac_option: invalid host type" 1>&2 + fi + if test "x$nonopt" != xNONE; then + { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } + fi + nonopt="$ac_option" + ;; + + esac +done + +if test -n "$ac_prev"; then + { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } +fi + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +# File descriptor usage: +# 0 standard input +# 1 file creation +# 2 errors and warnings +# 3 some systems may open it to /dev/tty +# 4 used on the Kubota Titan +# 6 checking for... messages and results +# 5 compiler messages saved in config.log +if test "$silent" = yes; then + exec 6>/dev/null +else + exec 6>&1 +fi +exec 5>./config.log + +echo "\ +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. +" 1>&5 + +# Strip out --no-create and --no-recursion so they do not pile up. +# Also quote any args containing shell metacharacters. +ac_configure_args= +for ac_arg +do + case "$ac_arg" in + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) ;; + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) + ac_configure_args="$ac_configure_args '$ac_arg'" ;; + *) ac_configure_args="$ac_configure_args $ac_arg" ;; + esac +done + +# NLS nuisances. +# Only set these to C if already set. These must not be set unconditionally +# because not all systems understand e.g. LANG=C (notably SCO). +# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'! +# Non-C LC_CTYPE values break the ctype check. +if test "${LANG+set}" = set; then LANG=C; export LANG; fi +if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi +if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi +if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -rf conftest* confdefs.h +# AIX cpp loses on an empty file, so make sure it contains at least a newline. +echo > confdefs.h + +# A filename unique to this package, relative to the directory that +# configure is in, which we can look for to find out if srcdir is correct. +ac_unique_file=libF77/Version.c + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then its parent. + ac_prog=$0 + ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` + test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. + srcdir=$ac_confdir + if test ! -r $srcdir/$ac_unique_file; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r $srcdir/$ac_unique_file; then + if test "$ac_srcdir_defaulted" = yes; then + { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } + else + { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } + fi +fi +srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` + +# Prefer explicitly selected file to automatically selected ones. +if test -z "$CONFIG_SITE"; then + if test "x$prefix" != xNONE; then + CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" + else + CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" + fi +fi +for ac_site_file in $CONFIG_SITE; do + if test -r "$ac_site_file"; then + echo "loading site script $ac_site_file" + . "$ac_site_file" + fi +done + +if test -r "$cache_file"; then + echo "loading cache $cache_file" + . $cache_file +else + echo "creating cache $cache_file" + > $cache_file +fi + +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross + +if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then + # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. + if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then + ac_n= ac_c=' +' ac_t=' ' + else + ac_n=-n ac_c= ac_t= + fi +else + ac_n= ac_c='\c' ac_t= +fi + + + +# From configure.in 1.10 + +# For g77 we'll set CC to point at the built gcc, but this will get it into +# the makefiles +# Extract the first word of "gcc", so it can be a program name with args. +set dummy gcc; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:530: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" + for ac_dir in $PATH; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_CC="gcc" + break + fi + done + IFS="$ac_save_ifs" +fi +fi +CC="$ac_cv_prog_CC" +if test -n "$CC"; then + echo "$ac_t""$CC" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + +if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:559: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" + ac_prog_rejected=no + for ac_dir in $PATH; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + if test "$ac_dir/$ac_word" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + break + fi + done + IFS="$ac_save_ifs" +if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# -gt 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + set dummy "$ac_dir/$ac_word" "$@" + shift + ac_cv_prog_CC="$@" + fi +fi +fi +fi +CC="$ac_cv_prog_CC" +if test -n "$CC"; then + echo "$ac_t""$CC" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + + test -z "$CC" && { echo "configure: error: no acceptable cc found in \$PATH" 1>&2; exit 1; } +fi + +echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 +echo "configure:607: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 + +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then + ac_cv_prog_cc_works=yes + # If we can't run a trivial program, we are probably using a cross compiler. + if (./conftest; exit) 2>/dev/null; then + ac_cv_prog_cc_cross=no + else + ac_cv_prog_cc_cross=yes + fi +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + ac_cv_prog_cc_works=no +fi +rm -fr conftest* + +echo "$ac_t""$ac_cv_prog_cc_works" 1>&6 +if test $ac_cv_prog_cc_works = no; then + { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } +fi +echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 +echo "configure:641: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 +cross_compiling=$ac_cv_prog_cc_cross + +echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 +echo "configure:646: checking whether we are using GNU C" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.c <&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then + ac_cv_prog_gcc=yes +else + ac_cv_prog_gcc=no +fi +fi + +echo "$ac_t""$ac_cv_prog_gcc" 1>&6 + +if test $ac_cv_prog_gcc = yes; then + GCC=yes + ac_test_CFLAGS="${CFLAGS+set}" + ac_save_CFLAGS="$CFLAGS" + CFLAGS= + echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 +echo "configure:670: checking whether ${CC-cc} accepts -g" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + echo 'void f(){}' > conftest.c +if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then + ac_cv_prog_cc_g=yes +else + ac_cv_prog_cc_g=no +fi +rm -f conftest* + +fi + +echo "$ac_t""$ac_cv_prog_cc_g" 1>&6 + if test "$ac_test_CFLAGS" = set; then + CFLAGS="$ac_save_CFLAGS" + elif test $ac_cv_prog_cc_g = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-O2" + fi +else + GCC= + test "${CFLAGS+set}" = set || CFLAGS="-g" +fi + +if test "$CROSS";then + ac_cv_c_cross=yes +else + ac_cv_c_cross=no +fi + +test "$AR" || AR=ar + +if test "$RANLIB"; then : + +else + RANLIB_TEST=true + # Extract the first word of "ranlib", so it can be a program name with args. +set dummy ranlib; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:712: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$RANLIB"; then + ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" + for ac_dir in $PATH; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_RANLIB="ranlib" + break + fi + done + IFS="$ac_save_ifs" + test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":" +fi +fi +RANLIB="$ac_cv_prog_RANLIB" +if test -n "$RANLIB"; then + echo "$ac_t""$RANLIB" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + +fi + + + + +# Sanity check for the cross-compilation case: +echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 +echo "configure:745: checking how to run the C preprocessor" >&5 +# On Suns, sometimes $CPP names a directory. +if test -n "$CPP" && test -d "$CPP"; then + CPP= +fi +if test -z "$CPP"; then +if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + # This must be in double quotes, not single quotes, because CPP may get + # substituted into the Makefile and "${CC-cc}" will confuse make. + CPP="${CC-cc} -E" + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. + cat > conftest.$ac_ext < +Syntax Error +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:766: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + : +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + CPP="${CC-cc} -E -traditional-cpp" + cat > conftest.$ac_ext < +Syntax Error +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:783: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + : +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + CPP=/lib/cpp +fi +rm -f conftest* +fi +rm -f conftest* + ac_cv_prog_CPP="$CPP" +fi + CPP="$ac_cv_prog_CPP" +else + ac_cv_prog_CPP="$CPP" +fi +echo "$ac_t""$CPP" 1>&6 + +ac_safe=`echo "stdio.h" | sed 'y%./+-%__p_%'` +echo $ac_n "checking for stdio.h""... $ac_c" 1>&6 +echo "configure:807: checking for stdio.h" >&5 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:817: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +{ echo "configure: error: Can't find stdio.h. +You must have a usable C system for the target already installed, at least +including headers and, preferably, the library, before you can configure +the G77 runtime system. If necessary, install gcc now with \`LANGUAGES=c', +then the target library, then build with \`LANGUAGES=f77'." 1>&2; exit 1; } +fi + + +echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 +echo "configure:845: checking for ANSI C header files" >&5 +if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#include +#include +#include +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:858: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + ac_cv_header_stdc=yes +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + ac_cv_header_stdc=no +fi +rm -f conftest* + +if test $ac_cv_header_stdc = yes; then + # SunOS 4.x string.h does not declare mem*, contrary to ANSI. +cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "memchr" >/dev/null 2>&1; then + : +else + rm -rf conftest* + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. +cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "free" >/dev/null 2>&1; then + : +else + rm -rf conftest* + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. +if test "$cross_compiling" = yes; then + : +else + cat > conftest.$ac_ext < +#define ISLOWER(c) ('a' <= (c) && (c) <= 'z') +#define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) +#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) +int main () { int i; for (i = 0; i < 256; i++) +if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2); +exit (0); } + +EOF +if { (eval echo configure:925: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null +then + : +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -fr conftest* + ac_cv_header_stdc=no +fi +rm -fr conftest* +fi + +fi +fi + +echo "$ac_t""$ac_cv_header_stdc" 1>&6 +if test $ac_cv_header_stdc = yes; then + cat >> confdefs.h <<\EOF +#define STDC_HEADERS 1 +EOF + +fi + + + +echo $ac_n "checking for posix""... $ac_c" 1>&6 +echo "configure:951: checking for posix" >&5 +if eval "test \"`echo '$''{'g77_cv_header_posix'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#include +#ifdef _POSIX_VERSION + yes +#endif + +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "yes" >/dev/null 2>&1; then + rm -rf conftest* + g77_cv_header_posix=yes +else + rm -rf conftest* + g77_cv_header_posix=no +fi +rm -f conftest* + +fi + +echo "$ac_t""$g77_cv_header_posix" 1>&6 + +# We can rely on the GNU library being posix-ish. I guess checking the +# header isn't actually like checking the functions, though... +echo $ac_n "checking for GNU library""... $ac_c" 1>&6 +echo "configure:982: checking for GNU library" >&5 +if eval "test \"`echo '$''{'g77_cv_lib_gnu'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#ifdef __GNU_LIBRARY__ + yes +#endif + +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "yes" >/dev/null 2>&1; then + rm -rf conftest* + g77_cv_lib_gnu=yes +else + rm -rf conftest* + g77_cv_lib_gnu=no +fi +rm -f conftest* + +fi + +echo "$ac_t""$g77_cv_lib_gnu" 1>&6 + +# Apparently cygwin needs to be special-cased. +echo $ac_n "checking for cyg\`win'32""... $ac_c" 1>&6 +echo "configure:1011: checking for cyg\`win'32" >&5 +if eval "test \"`echo '$''{'g77_cv_sys_cygwin32'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext <&5 | + egrep "yes" >/dev/null 2>&1; then + rm -rf conftest* + g77_cv_sys_cygwin32=yes +else + rm -rf conftest* + g77_cv_sys_cygwin32=no +fi +rm -f conftest* + +fi + +echo "$ac_t""$g77_cv_sys_cygwin32" 1>&6 + +ac_safe=`echo "fcntl.h" | sed 'y%./+-%__p_%'` +echo $ac_n "checking for fcntl.h""... $ac_c" 1>&6 +echo "configure:1039: checking for fcntl.h" >&5 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:1049: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + test $g77_cv_header_posix = yes && cat >> confdefs.h <<\EOF +#define _POSIX_SOURCE 1 +EOF + +else + echo "$ac_t""no" 1>&6 +cat >> confdefs.h <<\EOF +#define NO_FCNTL 1 +EOF + cat >> confdefs.h <<\EOF +#define OPEN_DECL 1 +EOF + +fi + + +echo $ac_n "checking for working const""... $ac_c" 1>&6 +echo "configure:1082: checking for working const" >&5 +if eval "test \"`echo '$''{'ac_cv_c_const'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext <j = 5; +} +{ /* ULTRIX-32 V3.1 (Rev 9) vcc rejects this */ + const int foo = 10; +} + +; return 0; } +EOF +if { (eval echo configure:1136: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + ac_cv_c_const=yes +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + ac_cv_c_const=no +fi +rm -f conftest* +fi + +echo "$ac_t""$ac_cv_c_const" 1>&6 +if test $ac_cv_c_const = no; then + cat >> confdefs.h <<\EOF +#define const +EOF + +fi + +echo $ac_n "checking for size_t""... $ac_c" 1>&6 +echo "configure:1157: checking for size_t" >&5 +if eval "test \"`echo '$''{'ac_cv_type_size_t'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#if STDC_HEADERS +#include +#include +#endif +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "size_t[^a-zA-Z_0-9]" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_type_size_t=yes +else + rm -rf conftest* + ac_cv_type_size_t=no +fi +rm -f conftest* + +fi +echo "$ac_t""$ac_cv_type_size_t" 1>&6 +if test $ac_cv_type_size_t = no; then + cat >> confdefs.h <<\EOF +#define size_t unsigned +EOF + +fi + + +echo $ac_n "checking return type of signal handlers""... $ac_c" 1>&6 +echo "configure:1191: checking return type of signal handlers" >&5 +if eval "test \"`echo '$''{'ac_cv_type_signal'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#include +#ifdef signal +#undef signal +#endif +#ifdef __cplusplus +extern "C" void (*signal (int, void (*)(int)))(int); +#else +void (*signal ()) (); +#endif + +int main() { +int i; +; return 0; } +EOF +if { (eval echo configure:1213: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + ac_cv_type_signal=void +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + ac_cv_type_signal=int +fi +rm -f conftest* +fi + +echo "$ac_t""$ac_cv_type_signal" 1>&6 +cat >> confdefs.h <&6 +echo "configure:1234: checking for atexit" >&5 +if eval "test \"`echo '$''{'ac_cv_func_atexit'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char atexit(); + +int main() { + +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_atexit) || defined (__stub___atexit) +choke me +#else +atexit(); +#endif + +; return 0; } +EOF +if { (eval echo configure:1262: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_func_atexit=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_func_atexit=no" +fi +rm -f conftest* +fi + +if eval "test \"`echo '$ac_cv_func_'atexit`\" = yes"; then + echo "$ac_t""yes" 1>&6 + cat >> confdefs.h <<\EOF +#define onexit atexit +EOF + +else + echo "$ac_t""no" 1>&6 + cat >> confdefs.h <<\EOF +#define NO_ONEXIT 1 +EOF + + echo $ac_n "checking for onexit""... $ac_c" 1>&6 +echo "configure:1287: checking for onexit" >&5 +if eval "test \"`echo '$''{'ac_cv_func_onexit'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char onexit(); + +int main() { + +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_onexit) || defined (__stub___onexit) +choke me +#else +onexit(); +#endif + +; return 0; } +EOF +if { (eval echo configure:1315: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_func_onexit=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_func_onexit=no" +fi +rm -f conftest* +fi + +if eval "test \"`echo '$ac_cv_func_'onexit`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +echo $ac_n "checking for on_exit""... $ac_c" 1>&6 +echo "configure:1333: checking for on_exit" >&5 +if eval "test \"`echo '$''{'ac_cv_func_on_exit'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char on_exit(); + +int main() { + +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_on_exit) || defined (__stub___on_exit) +choke me +#else +on_exit(); +#endif + +; return 0; } +EOF +if { (eval echo configure:1361: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_func_on_exit=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_func_on_exit=no" +fi +rm -f conftest* +fi + +if eval "test \"`echo '$ac_cv_func_'on_exit`\" = yes"; then + echo "$ac_t""yes" 1>&6 + cat >> confdefs.h <<\EOF +#define onexit on_exit +EOF + +else + echo "$ac_t""no" 1>&6 +fi + +fi + +fi + +else true +fi + +# This should always succeed on unix. +# Apparently positive result on cygwin loses re. NON_UNIX_STDIO +# (as of cygwin b18). +echo $ac_n "checking for fstat""... $ac_c" 1>&6 +echo "configure:1394: checking for fstat" >&5 +if eval "test \"`echo '$''{'ac_cv_func_fstat'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char fstat(); + +int main() { + +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_fstat) || defined (__stub___fstat) +choke me +#else +fstat(); +#endif + +; return 0; } +EOF +if { (eval echo configure:1422: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_func_fstat=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_func_fstat=no" +fi +rm -f conftest* +fi + +if eval "test \"`echo '$ac_cv_func_'fstat`\" = yes"; then + echo "$ac_t""yes" 1>&6 + : +else + echo "$ac_t""no" 1>&6 +fi + +echo $ac_n "checking need for NON_UNIX_STDIO""... $ac_c" 1>&6 +echo "configure:1442: checking need for NON_UNIX_STDIO" >&5 +if test $g77_cv_sys_cygwin32 = yes || test $ac_cv_func_fstat = no; then + echo "$ac_t""yes" 1>&6 + cat >> confdefs.h <<\EOF +#define NON_UNIX_STDIO 1 +EOF + +else + echo "$ac_t""no" 1>&6 +fi + +# This is necessary for e.g. Linux: +echo $ac_n "checking for necessary members of struct FILE""... $ac_c" 1>&6 +echo "configure:1455: checking for necessary members of struct FILE" >&5 +if eval "test \"`echo '$''{'g77_cv_struct_FILE'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +int main() { +FILE s; s._ptr; s._base; s._flag; +; return 0; } +EOF +if { (eval echo configure:1467: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + g77_cv_struct_FILE=yes +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + g77_cv_struct_FILE=no +fi +rm -f conftest* +fi +echo "$ac_t""$g77_cv_struct_FILE" 1>&6 +if test $g77_cv_struct_FILE = no; then + cat >> confdefs.h <<\EOF +#define MISSING_FILE_ELEMS 1 +EOF + +fi + +echo $ac_n "checking for drem in -lm""... $ac_c" 1>&6 +echo "configure:1487: checking for drem in -lm" >&5 +ac_lib_var=`echo m'_'drem | sed 'y%./+-%__p_%'` +if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + ac_save_LIBS="$LIBS" +LIBS="-lm $LIBS" +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=no" +fi +rm -f conftest* +LIBS="$ac_save_LIBS" + +fi +if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then + echo "$ac_t""yes" 1>&6 + cat >> confdefs.h <<\EOF +#define IEEE_drem 1 +EOF + +else + echo "$ac_t""no" 1>&6 +fi + + + +# posix will guarantee the right behaviour for sprintf, else we can't be +# sure; HEADER_STDC wouldn't be the right check in sunos4, for instance. +# However, on my sunos4/gcc setup unistd.h leads us wrongly to believe +# we're posix-conformant, so always do the test. +echo $ac_n "checking for ansi/posix sprintf result""... $ac_c" 1>&6 +echo "configure:1536: checking for ansi/posix sprintf result" >&5 +if test "$cross_compiling" = yes; then + g77_cv_sys_sprintf_ansi=no +else + cat > conftest.$ac_ext < + /* does sprintf return the number of chars transferred? */ + main () {char foo[2]; (sprintf(foo, "1") == 1) ? exit(0) : exit(1);} + +EOF +if { (eval echo configure:1548: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null +then + g77_cv_sys_sprintf_ansi=yes +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -fr conftest* + g77_cv_sys_sprintf_ansi=no +fi +rm -fr conftest* +fi + +if eval "test \"`echo '$''{'g77_cv_sys_sprintf_ansi'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + g77_cv_sys_sprintf_ansi=$g77_cv_sys_sprintf_ansi +fi + +if test $ac_cv_c_cross = no; then + echo "$ac_t""$g77_cv_sys_sprintf_ansi" 1>&6 +else + echo "$ac_t""can't tell -- assuming no" 1>&6 +fi +# The cygwin patch takes steps to avoid defining USE_STRLEN here -- I don't +# understand why. +if test $g77_cv_sys_sprintf_ansi != yes; then + cat >> confdefs.h <<\EOF +#define USE_STRLEN 1 +EOF + +fi + +# define NON_ANSI_RW_MODES on unix (can't hurt) +echo $ac_n "checking NON_ANSI_RW_MODES""... $ac_c" 1>&6 +echo "configure:1582: checking NON_ANSI_RW_MODES" >&5 +cat > conftest.$ac_ext <&5 | + egrep "yes" >/dev/null 2>&1; then + rm -rf conftest* + is_unix=yes +else + rm -rf conftest* + is_unix=no +fi +rm -f conftest* + +if test $g77_cv_sys_cygwin32 = yes; then + echo "$ac_t""no" 1>&6 +else + if test $is_unix = yes; then + cat >> confdefs.h <<\EOF +#define NON_ANSI_RW_MODES 1 +EOF + + echo "$ac_t""yes" 1>&6 + else + echo "$ac_t""no" 1>&6 + fi +fi + +# We have to firkle with the info in hconfig.h to figure out suitable types +# (via com.h). proj.h and com.h are in $srcdir/.., config.h which they need +# is in ../.. and the config files are in $srcdir/../../config. +echo $ac_n "checking f2c integer type""... $ac_c" 1>&6 +echo "configure:1625: checking f2c integer type" >&5 +late_ac_cpp=$ac_cpp +ac_cpp="$late_ac_cpp -I$srcdir/.. -I../.. -I$srcdir/../.. -I$srcdir/../../config" +if eval "test \"`echo '$''{'g77_cv_sys_f2cinteger'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext <&5 | + egrep "F2C_INTEGER=long int" >/dev/null 2>&1; then + rm -rf conftest* + g77_cv_sys_f2cinteger="long int" +fi +rm -f conftest* + +if test "$g77_cv_sys_f2cinteger" = ""; then + cat > conftest.$ac_ext <&5 | + egrep "F2C_INTEGER=int" >/dev/null 2>&1; then + rm -rf conftest* + g77_cv_sys_f2cinteger=int +fi +rm -f conftest* + +fi +if test "$g77_cv_sys_f2cinteger" = ""; then + echo "$ac_t""""" 1>&6 + { echo "configure: error: Can't determine type for f2c integer; config.log may help." 1>&2; exit 1; } +fi + +fi + +echo "$ac_t""$g77_cv_sys_f2cinteger" 1>&6 +F2C_INTEGER=$g77_cv_sys_f2cinteger +ac_cpp=$late_ac_cpp + + +echo $ac_n "checking f2c long int type""... $ac_c" 1>&6 +echo "configure:1690: checking f2c long int type" >&5 +late_ac_cpp=$ac_cpp +ac_cpp="$late_ac_cpp -I$srcdir/.. -I../.. -I$srcdir/../.. -I$srcdir/../../config" +if eval "test \"`echo '$''{'g77_cv_sys_f2clongint'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext <&5 | + egrep "F2C_LONGINT=long int" >/dev/null 2>&1; then + rm -rf conftest* + g77_cv_sys_f2clongint="long int" +fi +rm -f conftest* + +if test "$g77_cv_sys_f2clongint" = ""; then + cat > conftest.$ac_ext <&5 | + egrep "F2C_LONGINT=long long int" >/dev/null 2>&1; then + rm -rf conftest* + g77_cv_sys_f2clongint="long long int" +fi +rm -f conftest* + +fi +if test "$g77_cv_sys_f2clongint" = ""; then + echo "$ac_t""""" 1>&6 + { echo "configure: error: Can't determine type for f2c long int; config.log may help." 1>&2; exit 1; } +fi + +fi + +echo "$ac_t""$g77_cv_sys_f2clongint" 1>&6 +F2C_LONGINT=$g77_cv_sys_f2clongint +ac_cpp=$late_ac_cpp + + + + + + +# This EOF_CHAR is a misfeature on unix. +cat >> confdefs.h <<\EOF +#define NO_EOF_CHAR_CHECK 1 +EOF + + +cat >> confdefs.h <<\EOF +#define Skip_f2c_Undefs 1 +EOF + + + + + +cat >> confdefs.h <<\EOF +#define Pad_UDread 1 +EOF + + + + + +cat >> confdefs.h <<\EOF +#define WANT_LEAD_0 1 +EOF + + +# avoid confusion in case the `makefile's from the f2c distribution have +# got put here +test -f libF77/makefile && mv libF77/makefile libF77/makefile.ori +test -f libI77/makefile && mv libI77/makefile libI77/makefile.ori +test -f libU77/makefile && mv libU77/makefile libU77/makefile.ori + +trap '' 1 2 15 +cat > confcache <<\EOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs. It is not useful on other systems. +# If it contains results you don't want to keep, you may remove or edit it. +# +# By default, configure uses ./config.cache as the cache file, +# creating it if it does not exist already. You can give configure +# the --cache-file=FILE option to use a different cache file; that is +# what configure does when it calls configure scripts in +# subdirectories, so they share the cache. +# Giving --cache-file=/dev/null disables caching, for debugging configure. +# config.status only pays attention to the cache file if you give it the +# --recheck option to rerun configure. +# +EOF +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, don't put newlines in cache variables' values. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +(set) 2>&1 | + case `(ac_space=' '; set) 2>&1` in + *ac_space=\ *) + # `set' does not quote correctly, so add quotes (double-quote substitution + # turns \\\\ into \\, and sed turns \\ into \). + sed -n \ + -e "s/'/'\\\\''/g" \ + -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p" + ;; + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p' + ;; + esac >> confcache +if cmp -s $cache_file confcache; then + : +else + if test -w $cache_file; then + echo "updating cache $cache_file" + cat confcache > $cache_file + else + echo "not updating unwritable cache $cache_file" + fi +fi +rm -f confcache + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# Any assignment to VPATH causes Sun make to only execute +# the first set of double-colon rules, so remove it if not needed. +# If there is a colon in the path, we need to keep it. +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' +fi + +trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 + +# Transform confdefs.h into DEFS. +# Protect against shell expansion while executing Makefile rules. +# Protect against Makefile macro expansion. +cat > conftest.defs <<\EOF +s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g +s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g +s%\[%\\&%g +s%\]%\\&%g +s%\$%$$%g +EOF +DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '` +rm -f conftest.defs + + +# Without the "./", some shells look in PATH for config.status. +: ${CONFIG_STATUS=./config.status} + +echo creating $CONFIG_STATUS +rm -f $CONFIG_STATUS +cat > $CONFIG_STATUS </dev/null | sed 1q`: +# +# $0 $ac_configure_args +# +# Compiler output produced by configure, useful for debugging +# configure, is in ./config.log if it exists. + +ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" +for ac_option +do + case "\$ac_option" in + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" + exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; + -version | --version | --versio | --versi | --vers | --ver | --ve | --v) + echo "$CONFIG_STATUS generated by autoconf version 2.12" + exit 0 ;; + -help | --help | --hel | --he | --h) + echo "\$ac_cs_usage"; exit 0 ;; + *) echo "\$ac_cs_usage"; exit 1 ;; + esac +done + +ac_given_srcdir=$srcdir + +trap 'rm -fr `echo "Makefile ../../include/f2c.h:f2c.h.in libI77/Makefile libF77/Makefile libU77/Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 +EOF +cat >> $CONFIG_STATUS < conftest.subs <<\\CEOF +$ac_vpsub +$extrasub +s%@CFLAGS@%$CFLAGS%g +s%@CPPFLAGS@%$CPPFLAGS%g +s%@CXXFLAGS@%$CXXFLAGS%g +s%@DEFS@%$DEFS%g +s%@LDFLAGS@%$LDFLAGS%g +s%@LIBS@%$LIBS%g +s%@exec_prefix@%$exec_prefix%g +s%@prefix@%$prefix%g +s%@program_transform_name@%$program_transform_name%g +s%@bindir@%$bindir%g +s%@sbindir@%$sbindir%g +s%@libexecdir@%$libexecdir%g +s%@datadir@%$datadir%g +s%@sysconfdir@%$sysconfdir%g +s%@sharedstatedir@%$sharedstatedir%g +s%@localstatedir@%$localstatedir%g +s%@libdir@%$libdir%g +s%@includedir@%$includedir%g +s%@oldincludedir@%$oldincludedir%g +s%@infodir@%$infodir%g +s%@mandir@%$mandir%g +s%@CC@%$CC%g +s%@AR@%$AR%g +s%@RANLIB@%$RANLIB%g +s%@RANLIB_TEST@%$RANLIB_TEST%g +s%@CPP@%$CPP%g +s%@F2C_INTEGER@%$F2C_INTEGER%g +s%@F2C_LONGINT@%$F2C_LONGINT%g +s%@CROSS@%$CROSS%g + +CEOF +EOF + +cat >> $CONFIG_STATUS <<\EOF + +# Split the substitutions into bite-sized pieces for seds with +# small command number limits, like on Digital OSF/1 and HP-UX. +ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script. +ac_file=1 # Number of current file. +ac_beg=1 # First line for current file. +ac_end=$ac_max_sed_cmds # Line after last line for current file. +ac_more_lines=: +ac_sed_cmds="" +while $ac_more_lines; do + if test $ac_beg -gt 1; then + sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file + else + sed "${ac_end}q" conftest.subs > conftest.s$ac_file + fi + if test ! -s conftest.s$ac_file; then + ac_more_lines=false + rm -f conftest.s$ac_file + else + if test -z "$ac_sed_cmds"; then + ac_sed_cmds="sed -f conftest.s$ac_file" + else + ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file" + fi + ac_file=`expr $ac_file + 1` + ac_beg=$ac_end + ac_end=`expr $ac_end + $ac_max_sed_cmds` + fi +done +if test -z "$ac_sed_cmds"; then + ac_sed_cmds=cat +fi +EOF + +cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF +for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then + # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". + case "$ac_file" in + *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` + ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; + *) ac_file_in="${ac_file}.in" ;; + esac + + # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories. + + # Remove last slash and all that follows it. Not all systems have dirname. + ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` + if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then + # The file is in a subdirectory. + test ! -d "$ac_dir" && mkdir "$ac_dir" + ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" + # A "../" for each directory in $ac_dir_suffix. + ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` + else + ac_dir_suffix= ac_dots= + fi + + case "$ac_given_srcdir" in + .) srcdir=. + if test -z "$ac_dots"; then top_srcdir=. + else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; + /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; + *) # Relative path. + srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" + top_srcdir="$ac_dots$ac_given_srcdir" ;; + esac + + + echo creating "$ac_file" + rm -f "$ac_file" + configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." + case "$ac_file" in + *Makefile*) ac_comsub="1i\\ +# $configure_input" ;; + *) ac_comsub= ;; + esac + + ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` + sed -e "$ac_comsub +s%@configure_input@%$configure_input%g +s%@srcdir@%$srcdir%g +s%@top_srcdir@%$top_srcdir%g +" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file +fi; done +rm -f conftest.s* + +EOF +cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF + +exit 0 +EOF +chmod +x $CONFIG_STATUS +rm -fr confdefs* $ac_clean_files +test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 + + + diff --git a/gcc/f/runtime/configure.in b/gcc/f/runtime/configure.in new file mode 100644 index 000000000000..d2bcebae8657 --- /dev/null +++ b/gcc/f/runtime/configure.in @@ -0,0 +1,371 @@ +# Process this file with autoconf to produce a configure script. +# Copyright (C) 1995, 1997 Free Software Foundation, Inc. +# Contributed by Dave Love (d.love@dl.ac.uk). +# +#This file is part of GNU Fortran. +# +#GNU Fortran is free software; you can redistribute it and/or modify +#it under the terms of the GNU General Public License as published by +#the Free Software Foundation; either version 2, or (at your option) +#any later version. +# +#GNU Fortran is distributed in the hope that it will be useful, +#but WITHOUT ANY WARRANTY; without even the implied warranty of +#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +#GNU General Public License for more details. +# +#You should have received a copy of the GNU General Public License +#along with GNU Fortran; see the file COPYING. If not, write to +#the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +#02111-1307, USA. + +AC_INIT(libF77/Version.c) + +AC_REVISION(1.10) + +dnl Checks for programs. +# For g77 we'll set CC to point at the built gcc, but this will get it into +# the makefiles +AC_PROG_CC +dnl AC_C_CROSS +dnl Gives misleading `(cached)' message from the check. +if test "$CROSS";then + ac_cv_c_cross=yes +else + ac_cv_c_cross=no +fi + +dnl These should be inherited in the recursive make, but ensure they are +dnl defined: +test "$AR" || AR=ar +AC_SUBST(AR) +if test "$RANLIB"; then : + AC_SUBST(RANLIB) +else + RANLIB_TEST=true + AC_PROG_RANLIB +fi +AC_SUBST(RANLIB_TEST) + +dnl not needed for g77? +dnl AC_PROG_MAKE_SET + +dnl Checks for libraries. + +dnl Checks for header files. +# Sanity check for the cross-compilation case: +AC_CHECK_HEADER(stdio.h,:, + [AC_MSG_ERROR([Can't find stdio.h. +You must have a usable C system for the target already installed, at least +including headers and, preferably, the library, before you can configure +the G77 runtime system. If necessary, install gcc now with \`LANGUAGES=c', +then the target library, then build with \`LANGUAGES=f77'.])]) + +AC_HEADER_STDC +dnl We could do this if we didn't know we were using gcc +dnl AC_MSG_CHECKING(for prototype-savvy compiler) +dnl AC_CACHE_VAL(g77_cv_sys_proto, +dnl [AC_TRY_LINK(, +dnl dnl looks screwy because TRY_LINK expects a function body +dnl [return 0;} int foo (int * bar) {], +dnl g77_cv_sys_proto=yes, +dnl [g77_cv_sys_proto=no +dnl AC_DEFINE(KR_headers)])]) +dnl AC_MSG_RESULT($g77_cv_sys_proto) + +dnl for U77 +dnl AC_CHECK_HEADERS(unistd.h) + +AC_MSG_CHECKING(for posix) +AC_CACHE_VAL(g77_cv_header_posix, + AC_EGREP_CPP(yes, + [#include +#include +#ifdef _POSIX_VERSION + yes +#endif +], + g77_cv_header_posix=yes, + g77_cv_header_posix=no)) +AC_MSG_RESULT($g77_cv_header_posix) + +# We can rely on the GNU library being posix-ish. I guess checking the +# header isn't actually like checking the functions, though... +AC_MSG_CHECKING(for GNU library) +AC_CACHE_VAL(g77_cv_lib_gnu, + AC_EGREP_CPP(yes, + [#include +#ifdef __GNU_LIBRARY__ + yes +#endif +], + g77_cv_lib_gnu=yes, g77_cv_lib_gnu=no)) +AC_MSG_RESULT($g77_cv_lib_gnu) + +# Apparently cygwin needs to be special-cased. +AC_MSG_CHECKING([for cyg\`win'32]) +AC_CACHE_VAL(g77_cv_sys_cygwin32, + AC_EGREP_CPP(yes, + [#ifdef __CYGWIN32__ + yes +#endif +], + g77_cv_sys_cygwin32=yes, + g77_cv_sys_cygwin32=no)) +AC_MSG_RESULT($g77_cv_sys_cygwin32) + +AC_CHECK_HEADER(fcntl.h, + test $g77_cv_header_posix = yes && AC_DEFINE(_POSIX_SOURCE), + AC_DEFINE(NO_FCNTL) AC_DEFINE(OPEN_DECL)) + +dnl Checks for typedefs, structures, and compiler characteristics. +AC_C_CONST +AC_TYPE_SIZE_T + +dnl Checks for library functions. +AC_TYPE_SIGNAL +# we'll get atexit by default +if test $ac_cv_header_stdc != yes; then +AC_CHECK_FUNC(atexit, + AC_DEFINE(onexit,atexit),dnl just in case + [AC_DEFINE(NO_ONEXIT) + AC_CHECK_FUNC(onexit,, + [AC_CHECK_FUNC(on_exit, + AC_DEFINE(onexit,on_exit),)])]) +else true +fi + +# This should always succeed on unix. +# Apparently positive result on cygwin loses re. NON_UNIX_STDIO +# (as of cygwin b18). +AC_CHECK_FUNC(fstat) +AC_MSG_CHECKING([need for NON_UNIX_STDIO]) +if test $g77_cv_sys_cygwin32 = yes || test $ac_cv_func_fstat = no; then + AC_MSG_RESULT(yes) + AC_DEFINE(NON_UNIX_STDIO) +else + AC_MSG_RESULT(no) +fi + +# This is necessary for e.g. Linux: +AC_MSG_CHECKING([for necessary members of struct FILE]) +AC_CACHE_VAL(g77_cv_struct_FILE, +[AC_TRY_COMPILE([#include ], + [FILE s; s._ptr; s._base; s._flag;],g77_cv_struct_FILE=yes, + g77_cv_struct_FILE=no)])dnl +AC_MSG_RESULT($g77_cv_struct_FILE) +if test $g77_cv_struct_FILE = no; then + AC_DEFINE(MISSING_FILE_ELEMS) +fi + +dnl perhaps should check also for remainder +dnl Unfortunately, the message implies we're just checking for -lm... +AC_CHECK_LIB(m,drem,AC_DEFINE(IEEE_drem)) + +dnl for U77: +dnl AC_CHECK_FUNCS(symlink getcwd lstat) +dnl test $ac_cv_func_symlink = yes && SYMLNK=symlnk_.o +dnl test $ac_cv_func_lstat = yes && SYMLNK="$SYMLNK lstat_.o" +dnl AC_SUBST(SYMLNK) + +# posix will guarantee the right behaviour for sprintf, else we can't be +# sure; HEADER_STDC wouldn't be the right check in sunos4, for instance. +# However, on my sunos4/gcc setup unistd.h leads us wrongly to believe +# we're posix-conformant, so always do the test. +AC_MSG_CHECKING(for ansi/posix sprintf result) +dnl This loses if included as an argument to AC_CACHE_VAL because the +dnl changequote doesn't take effect and the [] vanish. +dnl fixme: use cached value +AC_TRY_RUN(changequote(<<, >>)dnl + <<#include + /* does sprintf return the number of chars transferred? */ + main () {char foo[2]; (sprintf(foo, "1") == 1) ? exit(0) : exit(1);} +>>changequote([, ]), + g77_cv_sys_sprintf_ansi=yes, + g77_cv_sys_sprintf_ansi=no, + g77_cv_sys_sprintf_ansi=no) +AC_CACHE_VAL(g77_cv_sys_sprintf_ansi, + g77_cv_sys_sprintf_ansi=$g77_cv_sys_sprintf_ansi) +dnl We get a misleading `(cached)' message... +if test $ac_cv_c_cross = no; then + AC_MSG_RESULT($g77_cv_sys_sprintf_ansi) +else + AC_MSG_RESULT([can't tell -- assuming no]) +fi +# The cygwin patch takes steps to avoid defining USE_STRLEN here -- I don't +# understand why. +if test $g77_cv_sys_sprintf_ansi != yes; then + AC_DEFINE(USE_STRLEN) +fi + +# define NON_ANSI_RW_MODES on unix (can't hurt) +AC_MSG_CHECKING(NON_ANSI_RW_MODES) +AC_EGREP_CPP(yes, +[#ifdef unix + yes +#endif +#ifdef __unix + yes +#endif +#ifdef __unix__ + yes +#endif +], is_unix=yes, is_unix=no) +if test $g77_cv_sys_cygwin32 = yes; then + AC_MSG_RESULT(no) +else + if test $is_unix = yes; then + AC_DEFINE(NON_ANSI_RW_MODES) + AC_MSG_RESULT(yes) + else + AC_MSG_RESULT(no) + fi +fi + +# We have to firkle with the info in hconfig.h to figure out suitable types +# (via com.h). proj.h and com.h are in $srcdir/.., config.h which they need +# is in ../.. and the config files are in $srcdir/../../config. +AC_MSG_CHECKING(f2c integer type) +late_ac_cpp=$ac_cpp +ac_cpp="$late_ac_cpp -I$srcdir/.. -I../.. -I$srcdir/../.. -I$srcdir/../../config" +AC_CACHE_VAL(g77_cv_sys_f2cinteger, +AC_EGREP_CPP(F2C_INTEGER=long int, +[#include "proj.h" +#define FFECOM_DETERMINE_TYPES 1 +#include "com.h" +#if FFECOM_f2cINTEGER == FFECOM_f2ccodeLONG +F2C_INTEGER=long int +#elif FFECOM_f2cINTEGER == FFECOM_f2ccodeINT +F2C_INTEGER=int +#else +# error "Cannot find a suitable type for F2C_INTEGER" +#endif +], + g77_cv_sys_f2cinteger="long int",) +if test "$g77_cv_sys_f2cinteger" = ""; then + AC_EGREP_CPP(F2C_INTEGER=int, +[#include "proj.h" +#define FFECOM_DETERMINE_TYPES 1 +#include "com.h" +#if FFECOM_f2cINTEGER == FFECOM_f2ccodeLONG +F2C_INTEGER=long int +#elif FFECOM_f2cINTEGER == FFECOM_f2ccodeINT +F2C_INTEGER=int +#else +# error "Cannot find a suitable type for F2C_INTEGER" +#endif +], + g77_cv_sys_f2cinteger=int,) +fi +if test "$g77_cv_sys_f2cinteger" = ""; then + AC_MSG_RESULT("") + AC_MSG_ERROR([Can't determine type for f2c integer; config.log may help.]) +fi +) +AC_MSG_RESULT($g77_cv_sys_f2cinteger) +F2C_INTEGER=$g77_cv_sys_f2cinteger +ac_cpp=$late_ac_cpp +AC_SUBST(F2C_INTEGER) + +AC_MSG_CHECKING(f2c long int type) +late_ac_cpp=$ac_cpp +ac_cpp="$late_ac_cpp -I$srcdir/.. -I../.. -I$srcdir/../.. -I$srcdir/../../config" +AC_CACHE_VAL(g77_cv_sys_f2clongint, +AC_EGREP_CPP(F2C_LONGINT=long int, +[#include "proj.h" +#define FFECOM_DETERMINE_TYPES 1 +#include "com.h" +#if FFECOM_f2cLONGINT == FFECOM_f2ccodeLONG +F2C_LONGINT=long int +#elif FFECOM_f2cLONGINT == FFECOM_f2ccodeLONGLONG +F2C_LONGINT=long long int +#else +# error "Cannot find a suitable type for F2C_LONGINT" +#endif +], + g77_cv_sys_f2clongint="long int",) +if test "$g77_cv_sys_f2clongint" = ""; then + AC_EGREP_CPP(F2C_LONGINT=long long int, +[#include "proj.h" +#define FFECOM_DETERMINE_TYPES 1 +#include "com.h" +#if FFECOM_f2cLONGINT == FFECOM_f2ccodeLONG +F2C_LONGINT=long int +#elif FFECOM_f2cLONGINT == FFECOM_f2ccodeLONGLONG +F2C_LONGINT=long long int +#else +# error "Cannot find a suitable type for F2C_LONGINT" +#endif +], + g77_cv_sys_f2clongint="long long int",) +fi +if test "$g77_cv_sys_f2clongint" = ""; then + AC_MSG_RESULT("") + AC_MSG_ERROR([Can't determine type for f2c long int; config.log may help.]) +fi +) +AC_MSG_RESULT($g77_cv_sys_f2clongint) +F2C_LONGINT=$g77_cv_sys_f2clongint +ac_cpp=$late_ac_cpp +AC_SUBST(F2C_LONGINT) + +dnl maybe check for drem/remainder + +AC_SUBST(CROSS) + + +# This EOF_CHAR is a misfeature on unix. +AC_DEFINE(NO_EOF_CHAR_CHECK) + +AC_DEFINE(Skip_f2c_Undefs) + +dnl Craig had these in f2c.h, but they're only relevant for building libf2c +dnl anyway. + +dnl For GNU Fortran (g77), we always enable the following behaviors for +dnl libf2c, to make things easy on the programmer. The alternate +dnl behaviors have their uses, and g77 might provide them as compiler, +dnl rather than library, options, so only a single copy of a shared libf2c +dnl need be built for a system. + +dnl This makes unformatted I/O more consistent in relation to other +dnl systems. It is not required by the F77 standard. + +AC_DEFINE(Pad_UDread) + +dnl This makes ERR= and IOSTAT= returns work properly in disk-full +dnl situations, making things work more as expected. It slows things +dnl down, so g77 will probably someday choose the original implementation +dnl on a case-by-case basis when it can be shown to not be necessary +dnl (e.g. no ERR= or IOSTAT=) or when it is given the appropriate +dnl compile-time option or, perhaps, source-code directive. + +dnl AC_DEFINE(ALWAYS_FLUSH) + +dnl Most Fortran implementations do this, so to make it easier +dnl to compare the output of g77-compiled programs to those compiled +dnl by most other compilers, tell libf2c to put leading zeros in +dnl appropriate places on output + +AC_DEFINE(WANT_LEAD_0) + +# avoid confusion in case the `makefile's from the f2c distribution have +# got put here +test -f libF77/makefile && mv libF77/makefile libF77/makefile.ori +test -f libI77/makefile && mv libI77/makefile libI77/makefile.ori +test -f libU77/makefile && mv libU77/makefile libU77/makefile.ori + +AC_OUTPUT(Makefile ../../include/f2c.h:f2c.h.in libI77/Makefile libF77/Makefile libU77/Makefile) + +dnl We might have configuration options to: +dnl * allow non-standard string concatenation (use libF77 s_catow.o, +dnl not s_cat.o) +dnl * change unit preconnexion in libI77/err.c (f_init.c) +dnl * -DALWAYS_FLUSH in libI77 +dnl * -DOMIT_BLANK_CC in libI77 + +dnl Local Variables: +dnl comment-start: "dnl " +dnl comment-end: "" +dnl comment-start-skip: "\\bdnl\\b\\s *" +dnl End: diff --git a/gcc/f/runtime/disclaimer.netlib b/gcc/f/runtime/disclaimer.netlib new file mode 100644 index 000000000000..a11108f83db9 --- /dev/null +++ b/gcc/f/runtime/disclaimer.netlib @@ -0,0 +1,15 @@ +f2c is a Fortran to C converter under development since 1990 by + David M. Gay (then AT&T Bell Labs, now Bell Labs, Lucent Technologies) + Stu Feldman (then at Bellcore, now at IBM) + Mark Maimone (Carnegie-Mellon University) + Norm Schryer (then AT&T Bell Labs, now AT&T Labs) +Please send bug reports to dmg@research.bell-labs.com . + +AT&T, Bellcore and Lucent disclaim all warranties with regard to this +software, including all implied warranties of merchantability +and fitness. In no event shall AT&T, Bellcore or Lucent be liable for +any special, indirect or consequential damages or any damages +whatsoever resulting from loss of use, data or profits, whether +in an action of contract, negligence or other tortious action, +arising out of or in connection with the use or performance of +this software. diff --git a/gcc/f/runtime/f2c.h.in b/gcc/f/runtime/f2c.h.in new file mode 100644 index 000000000000..903746781008 --- /dev/null +++ b/gcc/f/runtime/f2c.h.in @@ -0,0 +1,227 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +/* F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems */ +/* we assume short, float are OK */ +typedef @F2C_INTEGER@ /* long int */ integer; +typedef unsigned @F2C_INTEGER@ /* long */ uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef @F2C_INTEGER@ /* long int */ logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; +typedef @F2C_LONGINT@ /* long long */ longint; /* system-dependent */ +typedef unsigned @F2C_LONGINT@ /* long long */ ulongint; /* system-dependent */ +#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) +#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +#ifdef f2c_i2 +#error "f2c_i2 will not work with g77!!!!" +/* for -i2 */ +typedef short flag; +typedef short ftnlen; +typedef short ftnint; +#else +typedef @F2C_INTEGER@ /* long int */ flag; +typedef @F2C_INTEGER@ /* long int */ ftnlen; +typedef @F2C_INTEGER@ /* long int */ ftnint; +#endif + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (doublereal)abs(x) +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (doublereal)min(a,b) +#define dmax(a,b) (doublereal)max(a,b) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef int /* Unknown procedure type */ (*U_fp)(...); +typedef shortint (*J_fp)(...); +typedef integer (*I_fp)(...); +typedef real (*R_fp)(...); +typedef doublereal (*D_fp)(...), (*E_fp)(...); +typedef /* Complex */ VOID (*C_fp)(...); +typedef /* Double Complex */ VOID (*Z_fp)(...); +typedef logical (*L_fp)(...); +typedef shortlogical (*K_fp)(...); +typedef /* Character */ VOID (*H_fp)(...); +typedef /* Subroutine */ int (*S_fp)(...); +#else +typedef int /* Unknown procedure type */ (*U_fp)(); +typedef shortint (*J_fp)(); +typedef integer (*I_fp)(); +typedef real (*R_fp)(); +typedef doublereal (*D_fp)(), (*E_fp)(); +typedef /* Complex */ VOID (*C_fp)(); +typedef /* Double Complex */ VOID (*Z_fp)(); +typedef logical (*L_fp)(); +typedef shortlogical (*K_fp)(); +typedef /* Character */ VOID (*H_fp)(); +typedef /* Subroutine */ int (*S_fp)(); +#endif +/* E_fp is for real functions when -R is not specified */ +typedef VOID C_f; /* complex function */ +typedef VOID H_f; /* character function */ +typedef VOID Z_f; /* double complex function */ +typedef doublereal E_f; /* real function with -R not specified */ + +/* undef any lower-case symbols that your C compiler predefines, e.g.: */ + +#ifndef Skip_f2c_Undefs +/* (No such symbols should be defined in a strict ANSI C compiler. + We can avoid trouble with f2c-translated code by using + gcc -ansi [-traditional].) */ +#undef cray +#undef gcos +#undef mc68010 +#undef mc68020 +#undef mips +#undef pdp11 +#undef sgi +#undef sparc +#undef sun +#undef sun2 +#undef sun3 +#undef sun4 +#undef u370 +#undef u3b +#undef u3b2 +#undef u3b5 +#undef unix +#undef vax +#endif +#endif diff --git a/gcc/f/runtime/f2cext.c b/gcc/f/runtime/f2cext.c new file mode 100644 index 000000000000..199440975d47 --- /dev/null +++ b/gcc/f/runtime/f2cext.c @@ -0,0 +1,565 @@ +/* Copyright (C) 1997 Free Software Foundation, Inc. +This file is part of GNU Fortran run-time library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +#include +typedef int (*sig_proc)(int); + +#ifdef Labort +int abort_ (void) { + extern int G77_abort_0 (void); + return G77_abort_0 (); +} +#endif + +#ifdef Lderf +double derf_ (doublereal *x) { + extern double G77_derf_0 (doublereal *x); + return G77_derf_0 (x); +} +#endif + +#ifdef Lderfc +double derfc_ (doublereal *x) { + extern double G77_derfc_0 (doublereal *x); + return G77_derfc_0 (x); +} +#endif + +#ifdef Lef1asc +int ef1asc_ (ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) { + extern int G77_ef1asc_0 (ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb); + return G77_ef1asc_0 (a, la, b, lb); +} +#endif + +#ifdef Lef1cmc +integer ef1cmc_ (ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) { + extern integer G77_ef1cmc_0 (ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb); + return G77_ef1cmc_0 (a, la, b, lb); +} +#endif + +/* Note that erf*_ and bes*_ return doublereal, not real, as this + is the f2c interface, which is based on K&R C. */ + +#ifdef Lerf +doublereal erf_ (real *x) { + extern double G77_erf_0 (real *x); + return G77_erf_0 (x); +} +#endif + +#ifdef Lerfc +doublereal erfc_ (real *x) { + extern double G77_erfc_0 (real *x); + return G77_erfc_0 (x); +} +#endif + +#ifdef Lexit +void exit_ (integer *rc) { + extern void G77_exit_0 (integer *rc); + G77_exit_0 (rc); +} +#endif + +#ifdef Lgetarg +void getarg_ (ftnint *n, char *s, ftnlen ls) { + extern void G77_getarg_0 (ftnint *n, char *s, ftnlen ls); + G77_getarg_0 (n, s, ls); +} +#endif + +#ifdef Lgetenv +void getenv_ (char *fname, char *value, ftnlen flen, ftnlen vlen) { + extern void G77_getenv_0 (char *fname, char *value, ftnlen flen, ftnlen vlen); + G77_getenv_0 (fname, value, flen, vlen); +} +#endif + +#ifdef Liargc +ftnint iargc_ (void) { + extern ftnint G77_iargc_0 (void); + return G77_iargc_0 (); +} +#endif + +#ifdef Lsignal +ftnint signal_ (integer *sigp, sig_proc proc) { + extern ftnint G77_signal_0 (integer *sigp, sig_proc proc); + return G77_signal_0 (sigp, proc); +} +#endif + +#ifdef Lsystem +integer system_ (char *s, ftnlen n) { + extern integer G77_system_0 (char *s, ftnlen n); + return G77_system_0 (s, n); +} +#endif + +#ifdef Lflush +int flush_ (void) { + extern int G77_flush_0 (void); + return G77_flush_0 (); +} +#endif + +#ifdef Lftell +integer ftell_ (integer *Unit) { + extern integer G77_ftell_0 (integer *Unit); + return G77_ftell_0 (Unit); +} +#endif + +#ifdef Lfseek +integer fseek_ (integer *Unit, integer *offset, integer *xwhence) { + extern integer G77_fseek_0 (integer *Unit, integer *offset, integer *xwhence); + return G77_fseek_0 (Unit, offset, xwhence); +} +#endif + +#ifdef Laccess +integer access_ (const char *name, const char *mode, ftnlen Lname, ftnlen Lmode) { + extern integer G77_access_0 (const char *name, const char *mode, ftnlen Lname, ftnlen Lmode); + return G77_access_0 (name, mode, Lname, Lmode); +} +#endif + +#ifdef Lalarm +integer alarm_ (integer *seconds, sig_proc proc, integer *status) { + extern integer G77_alarm_0 (integer *seconds, sig_proc proc); + return G77_alarm_0 (seconds, proc); +} +#endif + +#ifdef Lbesj0 +doublereal besj0_ (const real *x) { + return j0 (*x); +} +#endif + +#ifdef Lbesj1 +doublereal besj1_ (const real *x) { + return j1 (*x); +} +#endif + +#ifdef Lbesjn +doublereal besjn_ (const integer *n, real *x) { + return jn (*n, *x); +} +#endif + +#ifdef Lbesy0 +doublereal besy0_ (const real *x) { + return y0 (*x); +} +#endif + +#ifdef Lbesy1 +doublereal besy1_ (const real *x) { + return y1 (*x); +} +#endif + +#ifdef Lbesyn +doublereal besyn_ (const integer *n, real *x) { + return yn (*n, *x); +} +#endif + +#ifdef Lchdir +integer chdir_ (const char *name, const ftnlen Lname) { + extern integer G77_chdir_0 (const char *name, const ftnlen Lname); + return G77_chdir_0 (name, Lname); +} +#endif + +#ifdef Lchmod +integer chmod_ (const char *name, const char *mode, const ftnlen Lname, const ftnlen Lmode) { + extern integer G77_chmod_0 (const char *name, const char *mode, const ftnlen Lname, const ftnlen Lmode); + return G77_chmod_0 (name, mode, Lname, Lmode); +} +#endif + +#ifdef Lctime +void ctime_ (char *chtime, const ftnlen Lchtime, longint *xstime) { + extern void G77_ctime_0 (char *chtime, const ftnlen Lchtime, longint *xstime); + G77_ctime_0 (chtime, Lchtime, xstime); +} +#endif + +#ifdef Ldate +int date_ (char *buf, ftnlen buf_len) { + extern int G77_date_0 (char *buf, ftnlen buf_len); + return G77_date_0 (buf, buf_len); +} +#endif + +#ifdef Ldbesj0 +doublereal dbesj0_ (const double *x) { + return j0 (*x); +} +#endif + +#ifdef Ldbesj1 +doublereal dbesj1_ (const double *x) { + return j1 (*x); +} +#endif + +#ifdef Ldbesjn +doublereal dbesjn_ (const integer *n, double *x) { + return jn (*n, *x); +} +#endif + +#ifdef Ldbesy0 +doublereal dbesy0_ (const double *x) { + return y0 (*x); +} +#endif + +#ifdef Ldbesy1 +doublereal dbesy1_ (const double *x) { + return y1 (*x); +} +#endif + +#ifdef Ldbesyn +doublereal dbesyn_ (const integer *n, double *x) { + return yn (*n, *x); +} +#endif + +#ifdef Ldtime +doublereal dtime_ (real tarray[2]) { + extern doublereal G77_dtime_0 (real tarray[2]); + return G77_dtime_0 (tarray); +} +#endif + +#ifdef Letime +doublereal etime_ (real tarray[2]) { + extern doublereal G77_etime_0 (real tarray[2]); + return G77_etime_0 (tarray); +} +#endif + +#ifdef Lfdate +void fdate_ (char *ret_val, ftnlen ret_val_len) { + extern void G77_fdate_0 (char *ret_val, ftnlen ret_val_len); + G77_fdate_0 (ret_val, ret_val_len); +} +#endif + +#ifdef Lfgetc +integer fgetc_ (const integer *lunit, char *c, ftnlen Lc) { + extern integer G77_fgetc_0 (const integer *lunit, char *c, ftnlen Lc); + return G77_fgetc_0 (lunit, c, Lc); +} +#endif + +#ifdef Lfget +integer fget_ (char *c, const ftnlen Lc) { + extern integer G77_fget_0 (char *c, const ftnlen Lc); + return G77_fget_0 (c, Lc); +} +#endif + +#ifdef Lflush1 +int flush1_ (const integer *lunit) { + extern int G77_flush1_0 (const integer *lunit); + return G77_flush1_0 (lunit); +} +#endif + +#ifdef Lfnum +integer fnum_ (integer *lunit) { + extern integer G77_fnum_0 (integer *lunit); + return G77_fnum_0 (lunit); +} +#endif + +#ifdef Lfputc +integer fputc_ (const integer *lunit, const char *c, const ftnlen Lc) { + extern integer G77_fputc_0 (const integer *lunit, const char *c, const ftnlen Lc); + return G77_fputc_0 (lunit, c, Lc); +} +#endif + +#ifdef Lfput +integer fput_ (const char *c, const ftnlen Lc) { + extern integer G77_fput_0 (const char *c, const ftnlen Lc); + return G77_fput_0 (c, Lc); +} +#endif + +#ifdef Lfstat +integer fstat_ (const integer *lunit, integer statb[13]) { + extern integer G77_fstat_0 (const integer *lunit, integer statb[13]); + return G77_fstat_0 (lunit, statb); +} +#endif + +#ifdef Lgerror +int gerror_ (char *str, ftnlen Lstr) { + extern int G77_gerror_0 (char *str, ftnlen Lstr); + return G77_gerror_0 (str, Lstr); +} +#endif + +#ifdef Lgetcwd +integer getcwd_ (char *str, const ftnlen Lstr) { + extern integer G77_getcwd_0 (char *str, const ftnlen Lstr); + return G77_getcwd_0 (str, Lstr); +} +#endif + +#ifdef Lgetgid +integer getgid_ (void) { + extern integer G77_getgid_0 (void); + return G77_getgid_0 (); +} +#endif + +#ifdef Lgetlog +int getlog_ (char *str, const ftnlen Lstr) { + extern int G77_getlog_0 (char *str, const ftnlen Lstr); + return G77_getlog_0 (str, Lstr); +} +#endif + +#ifdef Lgetpid +integer getpid_ (void) { + extern integer G77_getpid_0 (void); + return G77_getpid_0 (); +} +#endif + +#ifdef Lgetuid +integer getuid_ (void) { + extern integer G77_getuid_0 (void); + return G77_getuid_0 (); +} +#endif + +#ifdef Lgmtime +int gmtime_ (const integer *stime, integer tarray[9]) { + extern int G77_gmtime_0 (const integer *stime, integer tarray[9]); + return G77_gmtime_0 (stime, tarray); +} +#endif + +#ifdef Lhostnm +integer hostnm_ (char *name, ftnlen Lname) { + extern integer G77_hostnm_0 (char *name, ftnlen Lname); + return G77_hostnm_0 (name, Lname); +} +#endif + +#ifdef Lidate +int idate_ (int iarray[3]) { + extern int G77_idate_0 (int iarray[3]); + return G77_idate_0 (iarray); +} +#endif + +#ifdef Lierrno +integer ierrno_ (void) { + extern integer G77_ierrno_0 (void); + return G77_ierrno_0 (); +} +#endif + +#ifdef Lirand +integer irand_ (integer *flag) { + extern integer G77_irand_0 (integer *flag); + return G77_irand_0 (flag); +} +#endif + +#ifdef Lisatty +logical isatty_ (integer *lunit) { + extern logical G77_isatty_0 (integer *lunit); + return G77_isatty_0 (lunit); +} +#endif + +#ifdef Litime +int itime_ (integer tarray[3]) { + extern int G77_itime_0 (integer tarray[3]); + return G77_itime_0 (tarray); +} +#endif + +#ifdef Lkill +integer kill_ (const integer *pid, const integer *signum) { + extern integer G77_kill_0 (const integer *pid, const integer *signum); + return G77_kill_0 (pid, signum); +} +#endif + +#ifdef Llink +integer link_ (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2) { + extern integer G77_link_0 (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2); + return G77_link_0 (path1, path2, Lpath1, Lpath2); +} +#endif + +#ifdef Llnblnk +integer lnblnk_ (char *str, ftnlen str_len) { + extern integer G77_lnblnk_0 (char *str, ftnlen str_len); + return G77_lnblnk_0 (str, str_len); +} +#endif + +#ifdef Llstat +integer lstat_ (const char *name, integer statb[13], const ftnlen Lname) { + extern integer G77_lstat_0 (const char *name, integer statb[13], const ftnlen Lname); + return G77_lstat_0 (name, statb, Lname); +} +#endif + +#ifdef Lltime +int ltime_ (const integer *stime, integer tarray[9]) { + extern int G77_ltime_0 (const integer *stime, integer tarray[9]); + return G77_ltime_0 (stime, tarray); +} +#endif + +#ifdef Lmclock +longint mclock_ (void) { + extern longint G77_mclock_0 (void); + return G77_mclock_0 (); +} +#endif + +#ifdef Lperror +int perror_ (const char *str, const ftnlen Lstr) { + extern int G77_perror_0 (const char *str, const ftnlen Lstr); + return G77_perror_0 (str, Lstr); +} +#endif + +#ifdef Lrand +doublereal rand_ (integer *flag) { + extern doublereal G77_rand_0 (integer *flag); + return G77_rand_0 (flag); +} +#endif + +#ifdef Lrename +integer rename_ (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2) { + extern integer G77_rename_0 (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2); + return G77_rename_0 (path1, path2, Lpath1, Lpath2); +} +#endif + +#ifdef Lsecnds +doublereal secnds_ (real *r) { + extern doublereal G77_secnds_0 (real *r); + return G77_secnds_0 (r); +} +#endif + +#ifdef Lsecond +doublereal second_ () { + extern doublereal G77_second_0 (); + return G77_second_0 (); +} +#endif + +#ifdef Lsleep +int sleep_ (const integer *seconds) { + extern int G77_sleep_0 (const integer *seconds); + return G77_sleep_0 (seconds); +} +#endif + +#ifdef Lsrand +int srand_ (const integer *seed) { + extern int G77_srand_0 (const integer *seed); + return G77_srand_0 (seed); +} +#endif + +#ifdef Lstat +integer stat_ (const char *name, integer statb[13], const ftnlen Lname) { + extern integer G77_stat_0 (const char *name, integer statb[13], const ftnlen Lname); + return G77_stat_0 (name, statb, Lname); +} +#endif + +#ifdef Lsymlnk +integer symlnk_ (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2) { + extern integer G77_symlnk_0 (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2); + return G77_symlnk_0 (path1, path2, Lpath1, Lpath2); +} +#endif + +#ifdef Lsclock +int system_clock_ (integer *count, integer *count_rate, integer *count_max) { + extern int G77_system_clock_0 (integer *count, integer *count_rate, integer *count_max); + return G77_system_clock_0 (count, count_rate, count_max); +} +#endif + +#ifdef Ltime +longint time_ (void) { + extern longint G77_time_0 (void); + return G77_time_0 (); +} +#endif + +#ifdef Lttynam +void ttynam_ (char *ret_val, ftnlen ret_val_len, integer *lunit) { + extern void G77_ttynam_0 (char *ret_val, ftnlen ret_val_len, integer *lunit); + G77_ttynam_0 (ret_val, ret_val_len, lunit); +} +#endif + +#ifdef Lumask +integer umask_ (integer *mask) { + extern integer G77_umask_0 (integer *mask); + return G77_umask_0 (mask); +} +#endif + +#ifdef Lunlink +integer unlink_ (const char *str, const ftnlen Lstr) { + extern integer G77_unlink_0 (const char *str, const ftnlen Lstr); + return G77_unlink_0 (str, Lstr); +} +#endif + +#ifdef Lvxtidt +int vxtidate_ (integer *m, integer *d, integer *y) { + extern int G77_vxtidate_0 (integer *m, integer *d, integer *y); + return G77_vxtidate_0 (m, d, y); +} +#endif + +#ifdef Lvxttim +void vxttime_ (char chtime[8], const ftnlen Lchtime) { + extern void G77_vxttime_0 (char chtime[8], const ftnlen Lchtime); + G77_vxttime_0 (chtime, Lchtime); +} +#endif diff --git a/gcc/f/runtime/libF77/F77_aloc.c b/gcc/f/runtime/libF77/F77_aloc.c new file mode 100644 index 000000000000..8754fe2ef70e --- /dev/null +++ b/gcc/f/runtime/libF77/F77_aloc.c @@ -0,0 +1,32 @@ +#include "f2c.h" +#undef abs +#undef min +#undef max +#include + +static integer memfailure = 3; + +#ifdef KR_headers +extern char *malloc(); +extern void G77_exit_0 (); + + char * +F77_aloc(Len, whence) integer Len; char *whence; +#else +#include +extern void G77_exit_0 (integer*); + + char * +F77_aloc(integer Len, char *whence) +#endif +{ + char *rv; + unsigned int uLen = (unsigned int) Len; /* for K&R C */ + + if (!(rv = (char*)malloc(uLen))) { + fprintf(stderr, "malloc(%u) failure in %s\n", + uLen, whence); + G77_exit_0 (&memfailure); + } + return rv; + } diff --git a/gcc/f/runtime/libF77/Makefile.in b/gcc/f/runtime/libF77/Makefile.in new file mode 100644 index 000000000000..208626cb4a0c --- /dev/null +++ b/gcc/f/runtime/libF77/Makefile.in @@ -0,0 +1,95 @@ +# Makefile for GNU F77 compiler runtime. +# Copyright 1990 - 1994 by AT&T Bell Laboratories and Bellcore (see the +# file `Notice'). +# Portions of this file Copyright (C) 1995, 1996 Free Software Foundation, Inc. +# Contributed by Dave Love (d.love@dl.ac.uk). +# +#This file is part of GNU Fortran. +# +#GNU Fortran is free software; you can redistribute it and/or modify +#it under the terms of the GNU General Public License as published by +#the Free Software Foundation; either version 2, or (at your option) +#any later version. +# +#GNU Fortran is distributed in the hope that it will be useful, +#but WITHOUT ANY WARRANTY; without even the implied warranty of +#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +#GNU General Public License for more details. +# +#You should have received a copy of the GNU General Public License +#along with GNU Fortran; see the file COPYING. If not, write to +#the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +#02111-1307, USA. + +SHELL = /bin/sh + +srcdir = @srcdir@ +VPATH = @srcdir@ + +#### Start of system configuration section. #### + +# The _FOR_TARGET things are appropriate for a cross-make, passed by the +# superior makefile +GCC_FOR_TARGET = @CC@ +CC = $(GCC_FOR_TARGET) +CFLAGS = @CFLAGS@ $(GCC_FLAGS) +CPPFLAGS = @CPPFLAGS@ +DEFS = @DEFS@ +CGFLAGS = -g0 +# f2c.h should already be installed in xgcc's include directory but add that +# to -I anyhow in case not using xgcc. +ALL_CFLAGS = -I. -I$(srcdir) -I../../../include $(CPPFLAGS) $(DEFS) $(CFLAGS) +AR = @AR@ +AR_FLAGS = rc +RANLIB = @RANLIB@ +RANLIB_TEST = @RANLIB_TEST@ +CROSS = @CROSS@ + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $(CC) -c -DSkip_f2c_Undefs $(ALL_CFLAGS) $(CGFLAGS) $< + +MISC = F77_aloc.o VersionF.o main.o s_rnge.o abort_.o getarg_.o iargc_.o\ + getenv_.o signal_.o s_stop.o s_paus.o system_.o cabs.o\ + derf_.o derfc_.o erf_.o erfc_.o sig_die.o exit_.o +POW = pow_ci.o pow_dd.o pow_di.o pow_hh.o pow_ii.o pow_ri.o pow_zi.o pow_zz.o \ + pow_qq.o +CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o +DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o +REAL = r_abs.o r_acos.o r_asin.o r_atan.o r_atn2.o r_cnjg.o r_cos.o\ + r_cosh.o r_dim.o r_exp.o r_imag.o r_int.o\ + r_lg10.o r_log.o r_mod.o r_nint.o r_sign.o\ + r_sin.o r_sinh.o r_sqrt.o r_tan.o r_tanh.o +DBL = d_abs.o d_acos.o d_asin.o d_atan.o d_atn2.o\ + d_cnjg.o d_cos.o d_cosh.o d_dim.o d_exp.o\ + d_imag.o d_int.o d_lg10.o d_log.o d_mod.o\ + d_nint.o d_prod.o d_sign.o d_sin.o d_sinh.o\ + d_sqrt.o d_tan.o d_tanh.o +INT = i_abs.o i_dim.o i_dnnt.o i_indx.o i_len.o i_mod.o i_nint.o i_sign.o +HALF = h_abs.o h_dim.o h_dnnt.o h_indx.o h_len.o h_mod.o h_nint.o h_sign.o +CMP = l_ge.o l_gt.o l_le.o l_lt.o hl_ge.o hl_gt.o hl_le.o hl_lt.o +EFL = ef1asc_.o ef1cmc_.o +CHAR = s_cat.o s_cmp.o s_copy.o +F90BIT = lbitbits.o lbitshft.o qbitbits.o qbitshft.o + +F2C_H = ../../../include/f2c.h + +all: $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \ + $(HALF) $(CMP) $(EFL) $(CHAR) $(F90BIT) + +VersionF.o: Version.c + $(CC) -c $(CGFLAGS) -o $@ $(srcdir)/Version.c + +mostlyclean clean: + -rm -f *.o + +distclean maintainer-clean: clean + -rm -f stage? include Makefile + +# Not quite all these actually do depend on f2c.h... +$(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \ + $(HALF) $(CMP) $(EFL) $(CHAR) $(F90BIT): $(F2C_H) + +.PHONY: mostlyclean clean distclean maintainer-clean all diff --git a/gcc/f/runtime/libF77/Notice b/gcc/f/runtime/libF77/Notice new file mode 100644 index 000000000000..261b719bc57e --- /dev/null +++ b/gcc/f/runtime/libF77/Notice @@ -0,0 +1,23 @@ +/**************************************************************** +Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + diff --git a/gcc/f/runtime/libF77/README.netlib b/gcc/f/runtime/libF77/README.netlib new file mode 100644 index 000000000000..766821525517 --- /dev/null +++ b/gcc/f/runtime/libF77/README.netlib @@ -0,0 +1,108 @@ +If your compiler does not recognize ANSI C headers, +compile with KR_headers defined: either add -DKR_headers +to the definition of CFLAGS in the makefile, or insert + +#define KR_headers + +at the top of f2c.h , cabs.c , main.c , and sig_die.c . + +Under MS-DOS, compile s_paus.c with -DMSDOS. + +If you have a really ancient K&R C compiler that does not understand +void, add -Dvoid=int to the definition of CFLAGS in the makefile. + +If you use a C++ compiler, first create a local f2c.h by appending +f2ch.add to the usual f2c.h, e.g., by issuing the command + make f2c.h +which assumes f2c.h is installed in /usr/include . + +If your system lacks onexit() and you are not using an ANSI C +compiler, then you should compile main.c, s_paus.c, s_stop.c, and +sig_die.c with NO_ONEXIT defined. See the comments about onexit in +the makefile. + +If your system has a double drem() function such that drem(a,b) +is the IEEE remainder function (with double a, b), then you may +wish to compile r_mod.c and d_mod.c with IEEE_drem defined. +On some systems, you may also need to compile with -Ddrem=remainder . + +To check for transmission errors, issue the command + make check +This assumes you have the xsum program whose source, xsum.c, +is distributed as part of "all from f2c/src". If you do not +have xsum, you can obtain xsum.c by sending the following E-mail +message to netlib@netlib.bell-labs.com + send xsum.c from f2c/src + +The makefile assumes you have installed f2c.h in a standard +place (and does not cause recompilation when f2c.h is changed); +f2c.h comes with "all from f2c" (the source for f2c) and is +available separately ("f2c.h from f2c"). + +Most of the routines in libF77 are support routines for Fortran +intrinsic functions or for operations that f2c chooses not +to do "in line". There are a few exceptions, summarized below -- +functions and subroutines that appear to your program as ordinary +external Fortran routines. + +1. CALL ABORT prints a message and causes a core dump. + +2. ERF(r) and DERF(d) and the REAL and DOUBLE PRECISION + error functions (with x REAL and d DOUBLE PRECISION); + DERF must be declared DOUBLE PRECISION in your program. + Both ERF and DERF assume your C library provides the + underlying erf() function (which not all systems do). + +3. ERFC(r) and DERFC(d) are the complementary error functions: + ERFC(r) = 1 - ERF(r) and DERFC(d) = 1.d0 - DERFC(d) + (except that their results may be more accurate than + explicitly evaluating the above formulae would give). + Again, ERFC and r are REAL, and DERFC and d are DOUBLE + PRECISION (and must be declared as such in your program), + and ERFC and DERFC rely on your system's erfc(). + +4. CALL GETARG(n,s), where n is an INTEGER and s is a CHARACTER + variable, sets s to the n-th command-line argument (or to + all blanks if there are fewer than n command-line arguments); + CALL GETARG(0,s) sets s to the name of the program (on systems + that support this feature). See IARGC below. + +5. CALL GETENV(name, value), where name and value are of type + CHARACTER, sets value to the environment value, $name, of + name (or to blanks if $name has not been set). + +6. NARGS = IARGC() sets NARGS to the number of command-line + arguments (an INTEGER value). + +7. CALL SIGNAL(n,func), where n is an INTEGER and func is an + EXTERNAL procedure, arranges for func to be invoked when + signal n occurs (on systems where this makes sense). + +8. CALL SYSTEM(cmd), where cmd is of type CHARACTER, passes + cmd to the system's command processor (on systems where + this can be done). + +The makefile does not attempt to compile pow_qq.c, qbitbits.c, +and qbitshft.c, which are meant for use with INTEGER*8. To use +INTEGER*8, you must modify f2c.h to declare longint and ulongint +appropriately; then add pow_qq.o to the POW = line in the makefile, +and add " qbitbits.o qbitshft.o" to the makefile's F90BIT = line. + +Following Fortran 90, s_cat.c and s_copy.c allow the target of a +(character string) assignment to be appear on its right-hand, at +the cost of some extra overhead for all run-time concatenations. +If you prefer the extra efficiency that comes with the Fortran 77 +requirement that the left-hand side of a character assignment not +be involved in the right-hand side, compile s_cat.c and s_copy.c +with -DNO_OVERWRITE . + +If your system lacks a ranlib command, you don't need it. +Either comment out the makefile's ranlib invocation, or install +a harmless "ranlib" command somewhere in your PATH, such as the +one-line shell script + + exit 0 + +or (on some systems) + + exec /usr/bin/ar lts $1 >/dev/null diff --git a/gcc/f/runtime/libF77/Version.c b/gcc/f/runtime/libF77/Version.c new file mode 100644 index 000000000000..5d14f2a3f1dd --- /dev/null +++ b/gcc/f/runtime/libF77/Version.c @@ -0,0 +1,65 @@ +static char junk[] = "\n@(#)LIBF77 VERSION 19970404\n"; + +/* +*/ + +char __G77_LIBF77_VERSION__[] = "0.5.21-19970811"; + +/* +2.00 11 June 1980. File version.c added to library. +2.01 31 May 1988. s_paus() flushes stderr; names of hl_* fixed + [ d]erf[c ] added + 8 Aug. 1989: #ifdefs for f2c -i2 added to s_cat.c + 29 Nov. 1989: s_cmp returns long (for f2c) + 30 Nov. 1989: arg types from f2c.h + 12 Dec. 1989: s_rnge allows long names + 19 Dec. 1989: getenv_ allows unsorted environment + 28 Mar. 1990: add exit(0) to end of main() + 2 Oct. 1990: test signal(...) == SIG_IGN rather than & 01 in main + 17 Oct. 1990: abort() calls changed to sig_die(...,1) + 22 Oct. 1990: separate sig_die from main + 25 Apr. 1991: minor, theoretically invisible tweaks to s_cat, sig_die + 31 May 1991: make system_ return status + 18 Dec. 1991: change long to ftnlen (for -i2) many places + 28 Feb. 1992: repair z_sqrt.c (scribbled on input, gave wrong answer) + 18 July 1992: for n < 0, repair handling of 0**n in pow_[dr]i.c + and m**n in pow_hh.c and pow_ii.c; + catch SIGTRAP in main() for error msg before abort + 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined + 23 Oct. 1992: fix botch in signal_.c (erroneous deref of 2nd arg); + change Cabs to f__cabs. + 12 March 1993: various tweaks for C++ + 2 June 1994: adjust so abnormal terminations invoke f_exit just once + 16 Sept. 1994: s_cmp: treat characters as unsigned in comparisons. + 19 Sept. 1994: s_paus: flush after end of PAUSE; add -DMSDOS + 12 Jan. 1995: pow_[dhiqrz][hiq]: adjust x**i to work on machines + that sign-extend right shifts when i is the most + negative integer. + 26 Jan. 1995: adjust s_cat.c, s_copy.c to permit the left-hand side + of character assignments to appear on the right-hand + side (unless compiled with -DNO_OVERWRITE). + 27 Jan. 1995: minor tweak to s_copy.c: copy forward whenever + possible (for better cache behavior). + 30 May 1995: added subroutine exit(rc) integer rc. Version not changed. + 29 Aug. 1995: add F77_aloc.c; use it in s_cat.c and system_.c. + 6 Sept. 1995: fix return type of system_ under -DKR_headers. + 19 Dec. 1995: s_cat.c: fix bug when 2nd or later arg overlaps lhs. + 19 Mar. 1996: s_cat.c: supply missing break after overlap detection. + 13 May 1996: add [lq]bitbits.c and [lq]bitshft.c (f90 bit intrinsics). + 19 June 1996: add casts to unsigned in [lq]bitshft.c. + 26 Feb. 1997: adjust functions with a complex output argument + to permit aliasing it with input arguments. + (For now, at least, this is just for possible + benefit of g77.) + 4 April 1997: [cz]_div.c: tweaks invisible on most systems (that may + affect systems using gratuitous extra precision). +*/ + +#include + +void +g77__fvers__ () +{ + fprintf (stderr, "__G77_LIBF77_VERSION__: %s", __G77_LIBF77_VERSION__); + fputs (junk, stderr); +} diff --git a/gcc/f/runtime/libF77/abort_.c b/gcc/f/runtime/libF77/abort_.c new file mode 100644 index 000000000000..8efdc42f9705 --- /dev/null +++ b/gcc/f/runtime/libF77/abort_.c @@ -0,0 +1,18 @@ +#include +#include "f2c.h" + +#ifdef KR_headers +extern VOID sig_die(); + +int G77_abort_0 () +#else +extern void sig_die(char*,int); + +int G77_abort_0 (void) +#endif +{ +sig_die("Fortran abort routine called", 1); +#ifdef __cplusplus +return 0; +#endif +} diff --git a/gcc/f/runtime/libF77/c_abs.c b/gcc/f/runtime/libF77/c_abs.c new file mode 100644 index 000000000000..041fbd3d8bb0 --- /dev/null +++ b/gcc/f/runtime/libF77/c_abs.c @@ -0,0 +1,14 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double f__cabs(); + +double c_abs(z) complex *z; +#else +extern double f__cabs(double, double); + +double c_abs(complex *z) +#endif +{ +return( f__cabs( z->r, z->i ) ); +} diff --git a/gcc/f/runtime/libF77/c_cos.c b/gcc/f/runtime/libF77/c_cos.c new file mode 100644 index 000000000000..9e833c168b3b --- /dev/null +++ b/gcc/f/runtime/libF77/c_cos.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double sin(), cos(), sinh(), cosh(); + +VOID c_cos(resx, z) complex *resx, *z; +#else +#undef abs +#include + +void c_cos(complex *resx, complex *z) +#endif +{ +complex res; + +res.r = cos(z->r) * cosh(z->i); +res.i = - sin(z->r) * sinh(z->i); + +resx->r = res.r; +resx->i = res.i; +} diff --git a/gcc/f/runtime/libF77/c_div.c b/gcc/f/runtime/libF77/c_div.c new file mode 100644 index 000000000000..9568354bd53b --- /dev/null +++ b/gcc/f/runtime/libF77/c_div.c @@ -0,0 +1,40 @@ +#include "f2c.h" + +#ifdef KR_headers +extern VOID sig_die(); +VOID c_div(resx, a, b) +complex *a, *b, *resx; +#else +extern void sig_die(char*,int); +void c_div(complex *resx, complex *a, complex *b) +#endif +{ +double ratio, den; +double abr, abi; +complex res; + +if( (abr = b->r) < 0.) + abr = - abr; +if( (abi = b->i) < 0.) + abi = - abi; +if( abr <= abi ) + { + if(abi == 0) + sig_die("complex division by zero", 1); + ratio = (double)b->r / b->i ; + den = b->i * (1 + ratio*ratio); + res.r = (a->r*ratio + a->i) / den; + res.i = (a->i*ratio - a->r) / den; + } + +else + { + ratio = (double)b->i / b->r ; + den = b->r * (1 + ratio*ratio); + res.r = (a->r + a->i*ratio) / den; + res.i = (a->i - a->r*ratio) / den; + } + +resx->r = res.r; +resx->i = res.i; +} diff --git a/gcc/f/runtime/libF77/c_exp.c b/gcc/f/runtime/libF77/c_exp.c new file mode 100644 index 000000000000..8d3d33d0fe35 --- /dev/null +++ b/gcc/f/runtime/libF77/c_exp.c @@ -0,0 +1,23 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double exp(), cos(), sin(); + + VOID c_exp(resx, z) complex *resx, *z; +#else +#undef abs +#include + +void c_exp(complex *resx, complex *z) +#endif +{ +double expx; +complex res; + +expx = exp(z->r); +res.r = expx * cos(z->i); +res.i = expx * sin(z->i); + +resx->r = res.r; +resx->i = res.i; +} diff --git a/gcc/f/runtime/libF77/c_log.c b/gcc/f/runtime/libF77/c_log.c new file mode 100644 index 000000000000..6715131ad1db --- /dev/null +++ b/gcc/f/runtime/libF77/c_log.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double log(), f__cabs(), atan2(); +VOID c_log(resx, z) complex *resx, *z; +#else +#undef abs +#include +extern double f__cabs(double, double); + +void c_log(complex *resx, complex *z) +#endif +{ +complex res; + +res.i = atan2(z->i, z->r); +res.r = log( f__cabs(z->r, z->i) ); + +resx->r = res.r; +resx->i = res.i; +} diff --git a/gcc/f/runtime/libF77/c_sin.c b/gcc/f/runtime/libF77/c_sin.c new file mode 100644 index 000000000000..7bf3e392bed0 --- /dev/null +++ b/gcc/f/runtime/libF77/c_sin.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double sin(), cos(), sinh(), cosh(); + +VOID c_sin(resx, z) complex *resx, *z; +#else +#undef abs +#include + +void c_sin(complex *resx, complex *z) +#endif +{ +complex res; + +res.r = sin(z->r) * cosh(z->i); +res.i = cos(z->r) * sinh(z->i); + +resx->r = res.r; +resx->i = res.i; +} diff --git a/gcc/f/runtime/libF77/c_sqrt.c b/gcc/f/runtime/libF77/c_sqrt.c new file mode 100644 index 000000000000..775977a87f7b --- /dev/null +++ b/gcc/f/runtime/libF77/c_sqrt.c @@ -0,0 +1,38 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double sqrt(), f__cabs(); + +VOID c_sqrt(resx, z) complex *resx, *z; +#else +#undef abs +#include +extern double f__cabs(double, double); + +void c_sqrt(complex *resx, complex *z) +#endif +{ +double mag, t; +complex res; + +if( (mag = f__cabs(z->r, z->i)) == 0.) + res.r = res.i = 0.; +else if(z->r > 0) + { + res.r = t = sqrt(0.5 * (mag + z->r) ); + t = z->i / t; + res.i = 0.5 * t; + } +else + { + t = sqrt(0.5 * (mag - z->r) ); + if(z->i < 0) + t = -t; + res.i = t; + t = z->i / t; + res.r = 0.5 * t; + } + +resx->r = res.r; +resx->i = res.i; +} diff --git a/gcc/f/runtime/libF77/cabs.c b/gcc/f/runtime/libF77/cabs.c new file mode 100644 index 000000000000..2fad044e8840 --- /dev/null +++ b/gcc/f/runtime/libF77/cabs.c @@ -0,0 +1,27 @@ +#ifdef KR_headers +extern double sqrt(); +double f__cabs(real, imag) double real, imag; +#else +#undef abs +#include +double f__cabs(double real, double imag) +#endif +{ +double temp; + +if(real < 0) + real = -real; +if(imag < 0) + imag = -imag; +if(imag > real){ + temp = real; + real = imag; + imag = temp; +} +if((real+imag) == real) + return(real); + +temp = imag/real; +temp = real*sqrt(1.0 + temp*temp); /*overflow!!*/ +return(temp); +} diff --git a/gcc/f/runtime/libF77/d_abs.c b/gcc/f/runtime/libF77/d_abs.c new file mode 100644 index 000000000000..cb157e067b73 --- /dev/null +++ b/gcc/f/runtime/libF77/d_abs.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +double d_abs(x) doublereal *x; +#else +double d_abs(doublereal *x) +#endif +{ +if(*x >= 0) + return(*x); +return(- *x); +} diff --git a/gcc/f/runtime/libF77/d_acos.c b/gcc/f/runtime/libF77/d_acos.c new file mode 100644 index 000000000000..33da5369db21 --- /dev/null +++ b/gcc/f/runtime/libF77/d_acos.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double acos(); +double d_acos(x) doublereal *x; +#else +#undef abs +#include +double d_acos(doublereal *x) +#endif +{ +return( acos(*x) ); +} diff --git a/gcc/f/runtime/libF77/d_asin.c b/gcc/f/runtime/libF77/d_asin.c new file mode 100644 index 000000000000..79b33ca1bd6d --- /dev/null +++ b/gcc/f/runtime/libF77/d_asin.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double asin(); +double d_asin(x) doublereal *x; +#else +#undef abs +#include +double d_asin(doublereal *x) +#endif +{ +return( asin(*x) ); +} diff --git a/gcc/f/runtime/libF77/d_atan.c b/gcc/f/runtime/libF77/d_atan.c new file mode 100644 index 000000000000..caea4a406e0b --- /dev/null +++ b/gcc/f/runtime/libF77/d_atan.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double atan(); +double d_atan(x) doublereal *x; +#else +#undef abs +#include +double d_atan(doublereal *x) +#endif +{ +return( atan(*x) ); +} diff --git a/gcc/f/runtime/libF77/d_atn2.c b/gcc/f/runtime/libF77/d_atn2.c new file mode 100644 index 000000000000..6748a55d56fb --- /dev/null +++ b/gcc/f/runtime/libF77/d_atn2.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double atan2(); +double d_atn2(x,y) doublereal *x, *y; +#else +#undef abs +#include +double d_atn2(doublereal *x, doublereal *y) +#endif +{ +return( atan2(*x,*y) ); +} diff --git a/gcc/f/runtime/libF77/d_cnjg.c b/gcc/f/runtime/libF77/d_cnjg.c new file mode 100644 index 000000000000..1afa3bc4061e --- /dev/null +++ b/gcc/f/runtime/libF77/d_cnjg.c @@ -0,0 +1,17 @@ +#include "f2c.h" + + VOID +#ifdef KR_headers +d_cnjg(resx, z) doublecomplex *resx, *z; +#else +d_cnjg(doublecomplex *resx, doublecomplex *z) +#endif +{ +doublecomplex res; + +res.r = z->r; +res.i = - z->i; + +resx->r = res.r; +resx->i = res.i; +} diff --git a/gcc/f/runtime/libF77/d_cos.c b/gcc/f/runtime/libF77/d_cos.c new file mode 100644 index 000000000000..fa4d6ca406f1 --- /dev/null +++ b/gcc/f/runtime/libF77/d_cos.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double cos(); +double d_cos(x) doublereal *x; +#else +#undef abs +#include +double d_cos(doublereal *x) +#endif +{ +return( cos(*x) ); +} diff --git a/gcc/f/runtime/libF77/d_cosh.c b/gcc/f/runtime/libF77/d_cosh.c new file mode 100644 index 000000000000..edc0ebc10923 --- /dev/null +++ b/gcc/f/runtime/libF77/d_cosh.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double cosh(); +double d_cosh(x) doublereal *x; +#else +#undef abs +#include +double d_cosh(doublereal *x) +#endif +{ +return( cosh(*x) ); +} diff --git a/gcc/f/runtime/libF77/d_dim.c b/gcc/f/runtime/libF77/d_dim.c new file mode 100644 index 000000000000..1d0ecb7bbb64 --- /dev/null +++ b/gcc/f/runtime/libF77/d_dim.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +#ifdef KR_headers +double d_dim(a,b) doublereal *a, *b; +#else +double d_dim(doublereal *a, doublereal *b) +#endif +{ +return( *a > *b ? *a - *b : 0); +} diff --git a/gcc/f/runtime/libF77/d_exp.c b/gcc/f/runtime/libF77/d_exp.c new file mode 100644 index 000000000000..be12fd70551e --- /dev/null +++ b/gcc/f/runtime/libF77/d_exp.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double exp(); +double d_exp(x) doublereal *x; +#else +#undef abs +#include +double d_exp(doublereal *x) +#endif +{ +return( exp(*x) ); +} diff --git a/gcc/f/runtime/libF77/d_imag.c b/gcc/f/runtime/libF77/d_imag.c new file mode 100644 index 000000000000..793a3f9c4059 --- /dev/null +++ b/gcc/f/runtime/libF77/d_imag.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +#ifdef KR_headers +double d_imag(z) doublecomplex *z; +#else +double d_imag(doublecomplex *z) +#endif +{ +return(z->i); +} diff --git a/gcc/f/runtime/libF77/d_int.c b/gcc/f/runtime/libF77/d_int.c new file mode 100644 index 000000000000..beff1e7d3781 --- /dev/null +++ b/gcc/f/runtime/libF77/d_int.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +double d_int(x) doublereal *x; +#else +#undef abs +#include +double d_int(doublereal *x) +#endif +{ +return( (*x>0) ? floor(*x) : -floor(- *x) ); +} diff --git a/gcc/f/runtime/libF77/d_lg10.c b/gcc/f/runtime/libF77/d_lg10.c new file mode 100644 index 000000000000..c0892bd512aa --- /dev/null +++ b/gcc/f/runtime/libF77/d_lg10.c @@ -0,0 +1,15 @@ +#include "f2c.h" + +#define log10e 0.43429448190325182765 + +#ifdef KR_headers +double log(); +double d_lg10(x) doublereal *x; +#else +#undef abs +#include +double d_lg10(doublereal *x) +#endif +{ +return( log10e * log(*x) ); +} diff --git a/gcc/f/runtime/libF77/d_log.c b/gcc/f/runtime/libF77/d_log.c new file mode 100644 index 000000000000..592015b28212 --- /dev/null +++ b/gcc/f/runtime/libF77/d_log.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double log(); +double d_log(x) doublereal *x; +#else +#undef abs +#include +double d_log(doublereal *x) +#endif +{ +return( log(*x) ); +} diff --git a/gcc/f/runtime/libF77/d_mod.c b/gcc/f/runtime/libF77/d_mod.c new file mode 100644 index 000000000000..23f19299168e --- /dev/null +++ b/gcc/f/runtime/libF77/d_mod.c @@ -0,0 +1,40 @@ +#include "f2c.h" + +#ifdef KR_headers +#ifdef IEEE_drem +double drem(); +#else +double floor(); +#endif +double d_mod(x,y) doublereal *x, *y; +#else +#ifdef IEEE_drem +double drem(double, double); +#else +#undef abs +#include +#endif +double d_mod(doublereal *x, doublereal *y) +#endif +{ +#ifdef IEEE_drem + double xa, ya, z; + if ((ya = *y) < 0.) + ya = -ya; + z = drem(xa = *x, ya); + if (xa > 0) { + if (z < 0) + z += ya; + } + else if (z > 0) + z -= ya; + return z; +#else + double quotient; + if( (quotient = *x / *y) >= 0) + quotient = floor(quotient); + else + quotient = -floor(-quotient); + return(*x - (*y) * quotient ); +#endif +} diff --git a/gcc/f/runtime/libF77/d_nint.c b/gcc/f/runtime/libF77/d_nint.c new file mode 100644 index 000000000000..064beff669ce --- /dev/null +++ b/gcc/f/runtime/libF77/d_nint.c @@ -0,0 +1,14 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +double d_nint(x) doublereal *x; +#else +#undef abs +#include +double d_nint(doublereal *x) +#endif +{ +return( (*x)>=0 ? + floor(*x + .5) : -floor(.5 - *x) ); +} diff --git a/gcc/f/runtime/libF77/d_prod.c b/gcc/f/runtime/libF77/d_prod.c new file mode 100644 index 000000000000..3d4cef7835c2 --- /dev/null +++ b/gcc/f/runtime/libF77/d_prod.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +#ifdef KR_headers +double d_prod(x,y) real *x, *y; +#else +double d_prod(real *x, real *y) +#endif +{ +return( (*x) * (*y) ); +} diff --git a/gcc/f/runtime/libF77/d_sign.c b/gcc/f/runtime/libF77/d_sign.c new file mode 100644 index 000000000000..514ff0bbff82 --- /dev/null +++ b/gcc/f/runtime/libF77/d_sign.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +double d_sign(a,b) doublereal *a, *b; +#else +double d_sign(doublereal *a, doublereal *b) +#endif +{ +double x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} diff --git a/gcc/f/runtime/libF77/d_sin.c b/gcc/f/runtime/libF77/d_sin.c new file mode 100644 index 000000000000..fdd699eede53 --- /dev/null +++ b/gcc/f/runtime/libF77/d_sin.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double sin(); +double d_sin(x) doublereal *x; +#else +#undef abs +#include +double d_sin(doublereal *x) +#endif +{ +return( sin(*x) ); +} diff --git a/gcc/f/runtime/libF77/d_sinh.c b/gcc/f/runtime/libF77/d_sinh.c new file mode 100644 index 000000000000..77f36904f8e5 --- /dev/null +++ b/gcc/f/runtime/libF77/d_sinh.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double sinh(); +double d_sinh(x) doublereal *x; +#else +#undef abs +#include +double d_sinh(doublereal *x) +#endif +{ +return( sinh(*x) ); +} diff --git a/gcc/f/runtime/libF77/d_sqrt.c b/gcc/f/runtime/libF77/d_sqrt.c new file mode 100644 index 000000000000..b5cf83b946f8 --- /dev/null +++ b/gcc/f/runtime/libF77/d_sqrt.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double sqrt(); +double d_sqrt(x) doublereal *x; +#else +#undef abs +#include +double d_sqrt(doublereal *x) +#endif +{ +return( sqrt(*x) ); +} diff --git a/gcc/f/runtime/libF77/d_tan.c b/gcc/f/runtime/libF77/d_tan.c new file mode 100644 index 000000000000..af94a053223c --- /dev/null +++ b/gcc/f/runtime/libF77/d_tan.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double tan(); +double d_tan(x) doublereal *x; +#else +#undef abs +#include +double d_tan(doublereal *x) +#endif +{ +return( tan(*x) ); +} diff --git a/gcc/f/runtime/libF77/d_tanh.c b/gcc/f/runtime/libF77/d_tanh.c new file mode 100644 index 000000000000..92a02d4fd6ba --- /dev/null +++ b/gcc/f/runtime/libF77/d_tanh.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double tanh(); +double d_tanh(x) doublereal *x; +#else +#undef abs +#include +double d_tanh(doublereal *x) +#endif +{ +return( tanh(*x) ); +} diff --git a/gcc/f/runtime/libF77/derf_.c b/gcc/f/runtime/libF77/derf_.c new file mode 100644 index 000000000000..fba6b6b11f39 --- /dev/null +++ b/gcc/f/runtime/libF77/derf_.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +double erf(); +double G77_derf_0 (x) doublereal *x; +#else +extern double erf(double); +double G77_derf_0 (doublereal *x) +#endif +{ +return( erf(*x) ); +} diff --git a/gcc/f/runtime/libF77/derfc_.c b/gcc/f/runtime/libF77/derfc_.c new file mode 100644 index 000000000000..ae1ac7403022 --- /dev/null +++ b/gcc/f/runtime/libF77/derfc_.c @@ -0,0 +1,14 @@ +#include "f2c.h" + +#ifdef KR_headers +extern double erfc(); + +double G77_derfc_0 (x) doublereal *x; +#else +extern double erfc(double); + +double G77_derfc_0 (doublereal *x) +#endif +{ +return( erfc(*x) ); +} diff --git a/gcc/f/runtime/libF77/dtime_.c b/gcc/f/runtime/libF77/dtime_.c new file mode 100644 index 000000000000..2e775c6b84eb --- /dev/null +++ b/gcc/f/runtime/libF77/dtime_.c @@ -0,0 +1,45 @@ +#include "time.h" +#ifndef USE_CLOCK +#include "sys/types.h" +#include "sys/times.h" +#endif + +#undef Hz +#ifdef CLK_TCK +#define Hz CLK_TCK +#else +#ifdef HZ +#define Hz HZ +#else +#define Hz 60 +#endif +#endif + + float +#ifdef KR_headers +dtime_(tarray) float *tarray; +#else +dtime_(float *tarray) +#endif +{ +#ifdef USE_CLOCK +#ifndef CLOCKS_PER_SECOND +#define CLOCKS_PER_SECOND Hz +#endif + static double t0; + double t = clock(); + tarray[1] = 0; + tarray[0] = (t - t0) / CLOCKS_PER_SECOND; + t0 = t; + return tarray[0]; +#else + struct tms t; + static struct tms t0; + + times(&t); + tarray[0] = (t.tms_utime - t0.tms_utime) / Hz; + tarray[1] = (t.tms_stime - t0.tms_stime) / Hz; + t0 = t; + return tarray[0] + tarray[1]; +#endif + } diff --git a/gcc/f/runtime/libF77/ef1asc_.c b/gcc/f/runtime/libF77/ef1asc_.c new file mode 100644 index 000000000000..a922a1d9ba9d --- /dev/null +++ b/gcc/f/runtime/libF77/ef1asc_.c @@ -0,0 +1,21 @@ +/* EFL support routine to copy string b to string a */ + +#include "f2c.h" + + +#define M ( (long) (sizeof(long) - 1) ) +#define EVEN(x) ( ( (x)+ M) & (~M) ) + +#ifdef KR_headers +extern VOID s_copy(); +G77_ef1asc_0 (a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb; +#else +extern void s_copy(char*,char*,ftnlen,ftnlen); +int G77_ef1asc_0 (ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) +#endif +{ +s_copy( (char *)a, (char *)b, EVEN(*la), *lb ); +#ifdef __cplusplus +return 0; +#endif +} diff --git a/gcc/f/runtime/libF77/ef1cmc_.c b/gcc/f/runtime/libF77/ef1cmc_.c new file mode 100644 index 000000000000..f471172935f5 --- /dev/null +++ b/gcc/f/runtime/libF77/ef1cmc_.c @@ -0,0 +1,14 @@ +/* EFL support routine to compare two character strings */ + +#include "f2c.h" + +#ifdef KR_headers +extern integer s_cmp(); +integer G77_ef1cmc_0 (a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb; +#else +extern integer s_cmp(char*,char*,ftnlen,ftnlen); +integer G77_ef1cmc_0 (ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) +#endif +{ +return( s_cmp( (char *)a, (char *)b, *la, *lb) ); +} diff --git a/gcc/f/runtime/libF77/erf_.c b/gcc/f/runtime/libF77/erf_.c new file mode 100644 index 000000000000..1ba4350ad05c --- /dev/null +++ b/gcc/f/runtime/libF77/erf_.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +double erf(); +double G77_erf_0 (x) real *x; +#else +extern double erf(double); +double G77_erf_0 (real *x) +#endif +{ +return( erf(*x) ); +} diff --git a/gcc/f/runtime/libF77/erfc_.c b/gcc/f/runtime/libF77/erfc_.c new file mode 100644 index 000000000000..f44b1d49d84b --- /dev/null +++ b/gcc/f/runtime/libF77/erfc_.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +double erfc(); +double G77_erfc_0 (x) real *x; +#else +extern double erfc(double); +double G77_erfc_0 (real *x) +#endif +{ +return( erfc(*x) ); +} diff --git a/gcc/f/runtime/libF77/etime_.c b/gcc/f/runtime/libF77/etime_.c new file mode 100644 index 000000000000..0fb658af43ce --- /dev/null +++ b/gcc/f/runtime/libF77/etime_.c @@ -0,0 +1,38 @@ +#include "time.h" +#ifndef USE_CLOCK +#include "sys/types.h" +#include "sys/times.h" +#endif + +#undef Hz +#ifdef CLK_TCK +#define Hz CLK_TCK +#else +#ifdef HZ +#define Hz HZ +#else +#define Hz 60 +#endif +#endif + + float +#ifdef KR_headers +etime_(tarray) float *tarray; +#else +etime_(float *tarray) +#endif +{ +#ifdef USE_CLOCK +#ifndef CLOCKS_PER_SECOND +#define CLOCKS_PER_SECOND Hz +#endif + double t = clock(); + tarray[1] = 0; + return tarray[0] = t / CLOCKS_PER_SECOND; +#else + struct tms t; + + times(&t); + return (tarray[0] = t.tms_utime/Hz) + (tarray[1] = t.tms_stime/Hz); +#endif + } diff --git a/gcc/f/runtime/libF77/exit_.c b/gcc/f/runtime/libF77/exit_.c new file mode 100644 index 000000000000..4c0582add127 --- /dev/null +++ b/gcc/f/runtime/libF77/exit_.c @@ -0,0 +1,37 @@ +/* This gives the effect of + + subroutine exit(rc) + integer*4 rc + stop + end + + * with the added side effect of supplying rc as the program's exit code. + */ + +#include "f2c.h" +#undef abs +#undef min +#undef max +#ifndef KR_headers +#include +#ifdef __cplusplus +extern "C" { +#endif +extern void f_exit(void); +#endif + + void +#ifdef KR_headers +G77_exit_0 (rc) integer *rc; +#else +G77_exit_0 (integer *rc) +#endif +{ +#ifdef NO_ONEXIT + f_exit(); +#endif + exit(*rc); + } +#ifdef __cplusplus +} +#endif diff --git a/gcc/f/runtime/libF77/f2ch.add b/gcc/f/runtime/libF77/f2ch.add new file mode 100644 index 000000000000..a2acc17a1596 --- /dev/null +++ b/gcc/f/runtime/libF77/f2ch.add @@ -0,0 +1,162 @@ +/* If you are using a C++ compiler, append the following to f2c.h + for compiling libF77 and libI77. */ + +#ifdef __cplusplus +extern "C" { +extern int abort_(void); +extern double c_abs(complex *); +extern void c_cos(complex *, complex *); +extern void c_div(complex *, complex *, complex *); +extern void c_exp(complex *, complex *); +extern void c_log(complex *, complex *); +extern void c_sin(complex *, complex *); +extern void c_sqrt(complex *, complex *); +extern double d_abs(double *); +extern double d_acos(double *); +extern double d_asin(double *); +extern double d_atan(double *); +extern double d_atn2(double *, double *); +extern void d_cnjg(doublecomplex *, doublecomplex *); +extern double d_cos(double *); +extern double d_cosh(double *); +extern double d_dim(double *, double *); +extern double d_exp(double *); +extern double d_imag(doublecomplex *); +extern double d_int(double *); +extern double d_lg10(double *); +extern double d_log(double *); +extern double d_mod(double *, double *); +extern double d_nint(double *); +extern double d_prod(float *, float *); +extern double d_sign(double *, double *); +extern double d_sin(double *); +extern double d_sinh(double *); +extern double d_sqrt(double *); +extern double d_tan(double *); +extern double d_tanh(double *); +extern double derf_(double *); +extern double derfc_(double *); +extern integer do_fio(ftnint *, char *, ftnlen); +extern integer do_lio(ftnint *, ftnint *, char *, ftnlen); +extern integer do_uio(ftnint *, char *, ftnlen); +extern integer e_rdfe(void); +extern integer e_rdue(void); +extern integer e_rsfe(void); +extern integer e_rsfi(void); +extern integer e_rsle(void); +extern integer e_rsli(void); +extern integer e_rsue(void); +extern integer e_wdfe(void); +extern integer e_wdue(void); +extern integer e_wsfe(void); +extern integer e_wsfi(void); +extern integer e_wsle(void); +extern integer e_wsli(void); +extern integer e_wsue(void); +extern int ef1asc_(ftnint *, ftnlen *, ftnint *, ftnlen *); +extern integer ef1cmc_(ftnint *, ftnlen *, ftnint *, ftnlen *); +extern double erf(double); +extern double erf_(float *); +extern double erfc(double); +extern double erfc_(float *); +extern integer f_back(alist *); +extern integer f_clos(cllist *); +extern integer f_end(alist *); +extern void f_exit(void); +extern integer f_inqu(inlist *); +extern integer f_open(olist *); +extern integer f_rew(alist *); +extern int flush_(void); +extern void getarg_(integer *, char *, ftnlen); +extern void getenv_(char *, char *, ftnlen, ftnlen); +extern short h_abs(short *); +extern short h_dim(short *, short *); +extern short h_dnnt(double *); +extern short h_indx(char *, char *, ftnlen, ftnlen); +extern short h_len(char *, ftnlen); +extern short h_mod(short *, short *); +extern short h_nint(float *); +extern short h_sign(short *, short *); +extern short hl_ge(char *, char *, ftnlen, ftnlen); +extern short hl_gt(char *, char *, ftnlen, ftnlen); +extern short hl_le(char *, char *, ftnlen, ftnlen); +extern short hl_lt(char *, char *, ftnlen, ftnlen); +extern integer i_abs(integer *); +extern integer i_dim(integer *, integer *); +extern integer i_dnnt(double *); +extern integer i_indx(char *, char *, ftnlen, ftnlen); +extern integer i_len(char *, ftnlen); +extern integer i_mod(integer *, integer *); +extern integer i_nint(float *); +extern integer i_sign(integer *, integer *); +extern integer iargc_(void); +extern ftnlen l_ge(char *, char *, ftnlen, ftnlen); +extern ftnlen l_gt(char *, char *, ftnlen, ftnlen); +extern ftnlen l_le(char *, char *, ftnlen, ftnlen); +extern ftnlen l_lt(char *, char *, ftnlen, ftnlen); +extern void pow_ci(complex *, complex *, integer *); +extern double pow_dd(double *, double *); +extern double pow_di(double *, integer *); +extern short pow_hh(short *, shortint *); +extern integer pow_ii(integer *, integer *); +extern double pow_ri(float *, integer *); +extern void pow_zi(doublecomplex *, doublecomplex *, integer *); +extern void pow_zz(doublecomplex *, doublecomplex *, doublecomplex *); +extern double r_abs(float *); +extern double r_acos(float *); +extern double r_asin(float *); +extern double r_atan(float *); +extern double r_atn2(float *, float *); +extern void r_cnjg(complex *, complex *); +extern double r_cos(float *); +extern double r_cosh(float *); +extern double r_dim(float *, float *); +extern double r_exp(float *); +extern double r_imag(complex *); +extern double r_int(float *); +extern double r_lg10(float *); +extern double r_log(float *); +extern double r_mod(float *, float *); +extern double r_nint(float *); +extern double r_sign(float *, float *); +extern double r_sin(float *); +extern double r_sinh(float *); +extern double r_sqrt(float *); +extern double r_tan(float *); +extern double r_tanh(float *); +extern void s_cat(char *, char **, integer *, integer *, ftnlen); +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +extern void s_copy(char *, char *, ftnlen, ftnlen); +extern int s_paus(char *, ftnlen); +extern integer s_rdfe(cilist *); +extern integer s_rdue(cilist *); +extern integer s_rnge(char *, integer, char *, integer); +extern integer s_rsfe(cilist *); +extern integer s_rsfi(icilist *); +extern integer s_rsle(cilist *); +extern integer s_rsli(icilist *); +extern integer s_rsne(cilist *); +extern integer s_rsni(icilist *); +extern integer s_rsue(cilist *); +extern int s_stop(char *, ftnlen); +extern integer s_wdfe(cilist *); +extern integer s_wdue(cilist *); +extern integer s_wsfe(cilist *); +extern integer s_wsfi(icilist *); +extern integer s_wsle(cilist *); +extern integer s_wsli(icilist *); +extern integer s_wsne(cilist *); +extern integer s_wsni(icilist *); +extern integer s_wsue(cilist *); +extern void sig_die(char *, int); +extern integer signal_(integer *, void (*)(int)); +extern integer system_(char *, ftnlen); +extern double z_abs(doublecomplex *); +extern void z_cos(doublecomplex *, doublecomplex *); +extern void z_div(doublecomplex *, doublecomplex *, doublecomplex *); +extern void z_exp(doublecomplex *, doublecomplex *); +extern void z_log(doublecomplex *, doublecomplex *); +extern void z_sin(doublecomplex *, doublecomplex *); +extern void z_sqrt(doublecomplex *, doublecomplex *); + } +#endif diff --git a/gcc/f/runtime/libF77/getarg_.c b/gcc/f/runtime/libF77/getarg_.c new file mode 100644 index 000000000000..eaded2e4c9b0 --- /dev/null +++ b/gcc/f/runtime/libF77/getarg_.c @@ -0,0 +1,28 @@ +#include "f2c.h" + +/* + * subroutine getarg(k, c) + * returns the kth unix command argument in fortran character + * variable argument c +*/ + +#ifdef KR_headers +VOID G77_getarg_0 (n, s, ls) ftnint *n; register char *s; ftnlen ls; +#else +void G77_getarg_0 (ftnint *n, register char *s, ftnlen ls) +#endif +{ +extern int xargc; +extern char **xargv; +register char *t; +register int i; + +if(*n>=0 && *n= 0) + return(*x); +return(- *x); +} diff --git a/gcc/f/runtime/libF77/h_dim.c b/gcc/f/runtime/libF77/h_dim.c new file mode 100644 index 000000000000..ceff660e26cd --- /dev/null +++ b/gcc/f/runtime/libF77/h_dim.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +#ifdef KR_headers +shortint h_dim(a,b) shortint *a, *b; +#else +shortint h_dim(shortint *a, shortint *b) +#endif +{ +return( *a > *b ? *a - *b : 0); +} diff --git a/gcc/f/runtime/libF77/h_dnnt.c b/gcc/f/runtime/libF77/h_dnnt.c new file mode 100644 index 000000000000..9d0aa25f1d32 --- /dev/null +++ b/gcc/f/runtime/libF77/h_dnnt.c @@ -0,0 +1,14 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +shortint h_dnnt(x) doublereal *x; +#else +#undef abs +#include +shortint h_dnnt(doublereal *x) +#endif +{ +return( (*x)>=0 ? + floor(*x + .5) : -floor(.5 - *x) ); +} diff --git a/gcc/f/runtime/libF77/h_indx.c b/gcc/f/runtime/libF77/h_indx.c new file mode 100644 index 000000000000..a211cc7fa0fb --- /dev/null +++ b/gcc/f/runtime/libF77/h_indx.c @@ -0,0 +1,26 @@ +#include "f2c.h" + +#ifdef KR_headers +shortint h_indx(a, b, la, lb) char *a, *b; ftnlen la, lb; +#else +shortint h_indx(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +ftnlen i, n; +char *s, *t, *bend; + +n = la - lb + 1; +bend = b + lb; + +for(i = 0 ; i < n ; ++i) + { + s = a + i; + t = b; + while(t < bend) + if(*s++ != *t++) + goto no; + return((shortint)i+1); + no: ; + } +return(0); +} diff --git a/gcc/f/runtime/libF77/h_len.c b/gcc/f/runtime/libF77/h_len.c new file mode 100644 index 000000000000..00a2151bfa11 --- /dev/null +++ b/gcc/f/runtime/libF77/h_len.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +#ifdef KR_headers +shortint h_len(s, n) char *s; ftnlen n; +#else +shortint h_len(char *s, ftnlen n) +#endif +{ +return(n); +} diff --git a/gcc/f/runtime/libF77/h_mod.c b/gcc/f/runtime/libF77/h_mod.c new file mode 100644 index 000000000000..43431c1c503c --- /dev/null +++ b/gcc/f/runtime/libF77/h_mod.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +#ifdef KR_headers +shortint h_mod(a,b) short *a, *b; +#else +shortint h_mod(short *a, short *b) +#endif +{ +return( *a % *b); +} diff --git a/gcc/f/runtime/libF77/h_nint.c b/gcc/f/runtime/libF77/h_nint.c new file mode 100644 index 000000000000..0af3735da42f --- /dev/null +++ b/gcc/f/runtime/libF77/h_nint.c @@ -0,0 +1,14 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +shortint h_nint(x) real *x; +#else +#undef abs +#include +shortint h_nint(real *x) +#endif +{ +return( (*x)>=0 ? + floor(*x + .5) : -floor(.5 - *x) ); +} diff --git a/gcc/f/runtime/libF77/h_sign.c b/gcc/f/runtime/libF77/h_sign.c new file mode 100644 index 000000000000..7b06c157a74e --- /dev/null +++ b/gcc/f/runtime/libF77/h_sign.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +shortint h_sign(a,b) shortint *a, *b; +#else +shortint h_sign(shortint *a, shortint *b) +#endif +{ +shortint x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} diff --git a/gcc/f/runtime/libF77/hl_ge.c b/gcc/f/runtime/libF77/hl_ge.c new file mode 100644 index 000000000000..4c29527065a2 --- /dev/null +++ b/gcc/f/runtime/libF77/hl_ge.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +extern integer s_cmp(); +shortlogical hl_ge(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +shortlogical hl_ge(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) >= 0); +} diff --git a/gcc/f/runtime/libF77/hl_gt.c b/gcc/f/runtime/libF77/hl_gt.c new file mode 100644 index 000000000000..c4f345a0859e --- /dev/null +++ b/gcc/f/runtime/libF77/hl_gt.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +extern integer s_cmp(); +shortlogical hl_gt(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +shortlogical hl_gt(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) > 0); +} diff --git a/gcc/f/runtime/libF77/hl_le.c b/gcc/f/runtime/libF77/hl_le.c new file mode 100644 index 000000000000..a9cce596c715 --- /dev/null +++ b/gcc/f/runtime/libF77/hl_le.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +extern integer s_cmp(); +shortlogical hl_le(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +shortlogical hl_le(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) <= 0); +} diff --git a/gcc/f/runtime/libF77/hl_lt.c b/gcc/f/runtime/libF77/hl_lt.c new file mode 100644 index 000000000000..162d919c3b48 --- /dev/null +++ b/gcc/f/runtime/libF77/hl_lt.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +extern integer s_cmp(); +shortlogical hl_lt(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +shortlogical hl_lt(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) < 0); +} diff --git a/gcc/f/runtime/libF77/i_abs.c b/gcc/f/runtime/libF77/i_abs.c new file mode 100644 index 000000000000..be21295aaa12 --- /dev/null +++ b/gcc/f/runtime/libF77/i_abs.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +integer i_abs(x) integer *x; +#else +integer i_abs(integer *x) +#endif +{ +if(*x >= 0) + return(*x); +return(- *x); +} diff --git a/gcc/f/runtime/libF77/i_dim.c b/gcc/f/runtime/libF77/i_dim.c new file mode 100644 index 000000000000..6e1b1707b555 --- /dev/null +++ b/gcc/f/runtime/libF77/i_dim.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +#ifdef KR_headers +integer i_dim(a,b) integer *a, *b; +#else +integer i_dim(integer *a, integer *b) +#endif +{ +return( *a > *b ? *a - *b : 0); +} diff --git a/gcc/f/runtime/libF77/i_dnnt.c b/gcc/f/runtime/libF77/i_dnnt.c new file mode 100644 index 000000000000..8fcecb682007 --- /dev/null +++ b/gcc/f/runtime/libF77/i_dnnt.c @@ -0,0 +1,14 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +integer i_dnnt(x) doublereal *x; +#else +#undef abs +#include +integer i_dnnt(doublereal *x) +#endif +{ +return( (*x)>=0 ? + floor(*x + .5) : -floor(.5 - *x) ); +} diff --git a/gcc/f/runtime/libF77/i_indx.c b/gcc/f/runtime/libF77/i_indx.c new file mode 100644 index 000000000000..96e7bc51ba85 --- /dev/null +++ b/gcc/f/runtime/libF77/i_indx.c @@ -0,0 +1,26 @@ +#include "f2c.h" + +#ifdef KR_headers +integer i_indx(a, b, la, lb) char *a, *b; ftnlen la, lb; +#else +integer i_indx(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +ftnlen i, n; +char *s, *t, *bend; + +n = la - lb + 1; +bend = b + lb; + +for(i = 0 ; i < n ; ++i) + { + s = a + i; + t = b; + while(t < bend) + if(*s++ != *t++) + goto no; + return(i+1); + no: ; + } +return(0); +} diff --git a/gcc/f/runtime/libF77/i_len.c b/gcc/f/runtime/libF77/i_len.c new file mode 100644 index 000000000000..4020fee46183 --- /dev/null +++ b/gcc/f/runtime/libF77/i_len.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +#ifdef KR_headers +integer i_len(s, n) char *s; ftnlen n; +#else +integer i_len(char *s, ftnlen n) +#endif +{ +return(n); +} diff --git a/gcc/f/runtime/libF77/i_mod.c b/gcc/f/runtime/libF77/i_mod.c new file mode 100644 index 000000000000..6937c4213570 --- /dev/null +++ b/gcc/f/runtime/libF77/i_mod.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +#ifdef KR_headers +integer i_mod(a,b) integer *a, *b; +#else +integer i_mod(integer *a, integer *b) +#endif +{ +return( *a % *b); +} diff --git a/gcc/f/runtime/libF77/i_nint.c b/gcc/f/runtime/libF77/i_nint.c new file mode 100644 index 000000000000..c0f6795171f9 --- /dev/null +++ b/gcc/f/runtime/libF77/i_nint.c @@ -0,0 +1,14 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +integer i_nint(x) real *x; +#else +#undef abs +#include +integer i_nint(real *x) +#endif +{ +return( (*x)>=0 ? + floor(*x + .5) : -floor(.5 - *x) ); +} diff --git a/gcc/f/runtime/libF77/i_sign.c b/gcc/f/runtime/libF77/i_sign.c new file mode 100644 index 000000000000..94009b86e6fa --- /dev/null +++ b/gcc/f/runtime/libF77/i_sign.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +integer i_sign(a,b) integer *a, *b; +#else +integer i_sign(integer *a, integer *b) +#endif +{ +integer x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} diff --git a/gcc/f/runtime/libF77/iargc_.c b/gcc/f/runtime/libF77/iargc_.c new file mode 100644 index 000000000000..7ce5e08d3060 --- /dev/null +++ b/gcc/f/runtime/libF77/iargc_.c @@ -0,0 +1,11 @@ +#include "f2c.h" + +#ifdef KR_headers +ftnint G77_iargc_0 () +#else +ftnint G77_iargc_0 (void) +#endif +{ +extern int xargc; +return ( xargc - 1 ); +} diff --git a/gcc/f/runtime/libF77/l_ge.c b/gcc/f/runtime/libF77/l_ge.c new file mode 100644 index 000000000000..86b4a1f5a7f5 --- /dev/null +++ b/gcc/f/runtime/libF77/l_ge.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +extern integer s_cmp(); +logical l_ge(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +logical l_ge(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) >= 0); +} diff --git a/gcc/f/runtime/libF77/l_gt.c b/gcc/f/runtime/libF77/l_gt.c new file mode 100644 index 000000000000..c4b52f5bf7dd --- /dev/null +++ b/gcc/f/runtime/libF77/l_gt.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +extern integer s_cmp(); +logical l_gt(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +logical l_gt(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) > 0); +} diff --git a/gcc/f/runtime/libF77/l_le.c b/gcc/f/runtime/libF77/l_le.c new file mode 100644 index 000000000000..f2740a238143 --- /dev/null +++ b/gcc/f/runtime/libF77/l_le.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +extern integer s_cmp(); +logical l_le(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +logical l_le(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) <= 0); +} diff --git a/gcc/f/runtime/libF77/l_lt.c b/gcc/f/runtime/libF77/l_lt.c new file mode 100644 index 000000000000..c48dc946f9a7 --- /dev/null +++ b/gcc/f/runtime/libF77/l_lt.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +extern integer s_cmp(); +logical l_lt(a,b,la,lb) char *a, *b; ftnlen la, lb; +#else +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +logical l_lt(char *a, char *b, ftnlen la, ftnlen lb) +#endif +{ +return(s_cmp(a,b,la,lb) < 0); +} diff --git a/gcc/f/runtime/libF77/lbitbits.c b/gcc/f/runtime/libF77/lbitbits.c new file mode 100644 index 000000000000..75e9f9c603f9 --- /dev/null +++ b/gcc/f/runtime/libF77/lbitbits.c @@ -0,0 +1,62 @@ +#include "f2c.h" + +#ifndef LONGBITS +#define LONGBITS 32 +#endif + + integer +#ifdef KR_headers +lbit_bits(a, b, len) integer a, b, len; +#else +lbit_bits(integer a, integer b, integer len) +#endif +{ + /* Assume 2's complement arithmetic */ + + unsigned long x, y; + + x = (unsigned long) a; + y = (unsigned long)-1L; + x >>= b; + y <<= len; + return (integer)(x & ~y); + } + + integer +#ifdef KR_headers +lbit_cshift(a, b, len) integer a, b, len; +#else +lbit_cshift(integer a, integer b, integer len) +#endif +{ + unsigned long x, y, z; + + x = (unsigned long)a; + if (len <= 0) { + if (len == 0) + return 0; + goto full_len; + } + if (len >= LONGBITS) { + full_len: + if (b >= 0) { + b %= LONGBITS; + return (integer)(x << b | x >> LONGBITS -b ); + } + b = -b; + b %= LONGBITS; + return (integer)(x << LONGBITS - b | x >> b); + } + y = z = (unsigned long)-1; + y <<= len; + z &= ~y; + y &= x; + x &= z; + if (b >= 0) { + b %= len; + return (integer)(y | z & (x << b | x >> len - b)); + } + b = -b; + b %= len; + return (integer)(y | z & (x >> b | x << len - b)); + } diff --git a/gcc/f/runtime/libF77/lbitshft.c b/gcc/f/runtime/libF77/lbitshft.c new file mode 100644 index 000000000000..81b0fdbeaba1 --- /dev/null +++ b/gcc/f/runtime/libF77/lbitshft.c @@ -0,0 +1,11 @@ +#include "f2c.h" + + integer +#ifdef KR_headers +lbit_shift(a, b) integer a; integer b; +#else +lbit_shift(integer a, integer b) +#endif +{ + return b >= 0 ? a << b : (integer)((uinteger)a >> -b); + } diff --git a/gcc/f/runtime/libF77/main.c b/gcc/f/runtime/libF77/main.c new file mode 100644 index 000000000000..469a64bdcb3d --- /dev/null +++ b/gcc/f/runtime/libF77/main.c @@ -0,0 +1,135 @@ +/* STARTUP PROCEDURE FOR UNIX FORTRAN PROGRAMS */ + +#include +#include "signal1.h" + +#ifndef SIGIOT +#ifdef SIGABRT +#define SIGIOT SIGABRT +#endif +#endif + +#ifndef KR_headers +#undef VOID +#include +#endif + +#ifndef VOID +#define VOID void +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +#ifdef NO__STDC +#define ONEXIT onexit +extern VOID f_exit(); +#else +#ifndef KR_headers +extern void f_exit(void); +#ifndef NO_ONEXIT +#define ONEXIT atexit +extern int atexit(void (*)(void)); +#endif +#else +#ifndef NO_ONEXIT +#define ONEXIT onexit +extern VOID f_exit(); +#endif +#endif +#endif + +#ifdef KR_headers +extern VOID f_init(), sig_die(); +extern int MAIN__(); +#define Int /* int */ +#else +extern void f_init(void), sig_die(char*, int); +extern int MAIN__(void); +#define Int int +#endif + +static VOID sigfdie(Int n) +{ +sig_die("Floating Exception", 1); +} + + +static VOID sigidie(Int n) +{ +sig_die("IOT Trap", 1); +} + +#ifdef SIGQUIT +static VOID sigqdie(Int n) +{ +sig_die("Quit signal", 1); +} +#endif + + +static VOID sigindie(Int n) +{ +sig_die("Interrupt", 0); +} + +static VOID sigtdie(Int n) +{ +sig_die("Killed", 0); +} + +#ifdef SIGTRAP +static VOID sigtrdie(Int n) +{ +sig_die("Trace trap", 1); +} +#endif + + +int xargc; +char **xargv; + +#ifdef __cplusplus + } +#endif + +#ifdef KR_headers +main(argc, argv) int argc; char **argv; +#else +main(int argc, char **argv) +#endif +{ +xargc = argc; +xargv = argv; +signal1(SIGFPE, sigfdie); /* ignore underflow, enable overflow */ +#ifdef SIGIOT +signal1(SIGIOT, sigidie); +#endif +#ifdef SIGTRAP +signal1(SIGTRAP, sigtrdie); +#endif +#ifdef SIGQUIT +if(signal1(SIGQUIT,sigqdie) == SIG_IGN) + signal1(SIGQUIT, SIG_IGN); +#endif +if(signal1(SIGINT, sigindie) == SIG_IGN) + signal1(SIGINT, SIG_IGN); +signal1(SIGTERM,sigtdie); + +#ifdef pdp11 + ldfps(01200); /* detect overflow as an exception */ +#endif + +f_init(); +#ifndef NO_ONEXIT +ONEXIT(f_exit); +#endif +MAIN__(); +#ifdef NO_ONEXIT +f_exit(); +#endif +exit(0); /* exit(0) rather than return(0) to bypass Cray bug */ +return 0; /* For compilers that complain of missing return values; */ + /* others will complain that this is unreachable code. */ +} diff --git a/gcc/f/runtime/libF77/makefile.netlib b/gcc/f/runtime/libF77/makefile.netlib new file mode 100644 index 000000000000..230ca7e9f939 --- /dev/null +++ b/gcc/f/runtime/libF77/makefile.netlib @@ -0,0 +1,103 @@ +.SUFFIXES: .c .o +CC = cc +SHELL = /bin/sh +CFLAGS = -O + +# If your system lacks onexit() and you are not using an +# ANSI C compiler, then you should add -DNO_ONEXIT to CFLAGS, +# e.g., by changing the above "CFLAGS =" line to +# CFLAGS = -O -DNO_ONEXIT + +# On at least some Sun systems, it is more appropriate to change the +# "CFLAGS =" line to +# CFLAGS = -O -Donexit=on_exit + +# compile, then strip unnecessary symbols +.c.o: + $(CC) -c -DSkip_f2c_Undefs $(CFLAGS) $*.c + ld -r -x -o $*.xxx $*.o + mv $*.xxx $*.o +## Under Solaris (and other systems that do not understand ld -x), +## omit -x in the ld line above. +## If your system does not have the ld command, comment out +## or remove both the ld and mv lines above. + +MISC = F77_aloc.o Version.o main.o s_rnge.o abort_.o getarg_.o iargc_.o \ + getenv_.o signal_.o s_stop.o s_paus.o system_.o cabs.o\ + derf_.o derfc_.o erf_.o erfc_.o sig_die.o exit_.o +POW = pow_ci.o pow_dd.o pow_di.o pow_hh.o pow_ii.o pow_ri.o pow_zi.o pow_zz.o +CX = c_abs.o c_cos.o c_div.o c_exp.o c_log.o c_sin.o c_sqrt.o +DCX = z_abs.o z_cos.o z_div.o z_exp.o z_log.o z_sin.o z_sqrt.o +REAL = r_abs.o r_acos.o r_asin.o r_atan.o r_atn2.o r_cnjg.o r_cos.o\ + r_cosh.o r_dim.o r_exp.o r_imag.o r_int.o\ + r_lg10.o r_log.o r_mod.o r_nint.o r_sign.o\ + r_sin.o r_sinh.o r_sqrt.o r_tan.o r_tanh.o +DBL = d_abs.o d_acos.o d_asin.o d_atan.o d_atn2.o\ + d_cnjg.o d_cos.o d_cosh.o d_dim.o d_exp.o\ + d_imag.o d_int.o d_lg10.o d_log.o d_mod.o\ + d_nint.o d_prod.o d_sign.o d_sin.o d_sinh.o\ + d_sqrt.o d_tan.o d_tanh.o +INT = i_abs.o i_dim.o i_dnnt.o i_indx.o i_len.o i_mod.o i_nint.o i_sign.o +HALF = h_abs.o h_dim.o h_dnnt.o h_indx.o h_len.o h_mod.o h_nint.o h_sign.o +CMP = l_ge.o l_gt.o l_le.o l_lt.o hl_ge.o hl_gt.o hl_le.o hl_lt.o +EFL = ef1asc_.o ef1cmc_.o +CHAR = F77_aloc.o s_cat.o s_cmp.o s_copy.o +F90BIT = lbitbits.o lbitshft.o +QINT = pow_qq.o qbitbits.o qbitshft.o +TIME = dtime_.o etime_.o + +all: signal1.h libF77.a + +# You may need to adjust signal1.h suitably for your system... +signal1.h: signal1.h0 + cp signal1.h0 signal1.h + +# If you get an error compiling dtime_.c or etime_.c, try adding +# -DUSE_CLOCK to the CFLAGS assignment above; if that does not work, +# omit $(TIME) from the dependency list for libF77.a below. + +# For INTEGER*8 support (which requires system-dependent adjustments to +# f2c.h), add $(QINT) to the libf2c.a dependency list below... + +libF77.a : $(MISC) $(POW) $(CX) $(DCX) $(REAL) $(DBL) $(INT) \ + $(HALF) $(CMP) $(EFL) $(CHAR) $(F90BIT) $(TIME) + ar r libF77.a $? + -ranlib libF77.a + +### If your system lacks ranlib, you don't need it; see README. + +Version.o: Version.c + $(CC) -c Version.c + +# To compile with C++, first "make f2c.h" +f2c.h: f2ch.add + cat /usr/include/f2c.h f2ch.add >f2c.h + +install: libF77.a + mv libF77.a /usr/lib + ranlib /usr/lib/libF77.a + +clean: + rm -f libF77.a *.o + +check: + xsum F77_aloc.c Notice README Version.c abort_.c c_abs.c c_cos.c \ + c_div.c c_exp.c c_log.c c_sin.c c_sqrt.c cabs.c d_abs.c d_acos.c \ + d_asin.c d_atan.c d_atn2.c d_cnjg.c d_cos.c d_cosh.c d_dim.c \ + d_exp.c d_imag.c d_int.c d_lg10.c d_log.c d_mod.c d_nint.c \ + d_prod.c d_sign.c d_sin.c d_sinh.c d_sqrt.c d_tan.c d_tanh.c \ + derf_.c derfc_.c dtime_.c \ + ef1asc_.c ef1cmc_.c erf_.c erfc_.c etime_.c exit_.c f2ch.add \ + getarg_.c getenv_.c h_abs.c h_dim.c h_dnnt.c h_indx.c h_len.c \ + h_mod.c h_nint.c h_sign.c hl_ge.c hl_gt.c hl_le.c hl_lt.c \ + i_abs.c i_dim.c i_dnnt.c i_indx.c i_len.c i_mod.c i_nint.c \ + i_sign.c iargc_.c l_ge.c l_gt.c l_le.c l_lt.c lbitbits.c lbitshft.c \ + main.c makefile pow_ci.c pow_dd.c pow_di.c pow_hh.c pow_ii.c \ + pow_qq.c pow_ri.c pow_zi.c pow_zz.c qbitbits.c qbitshft.c \ + r_abs.c r_acos.c r_asin.c r_atan.c r_atn2.c \ + r_cnjg.c r_cos.c r_cosh.c r_dim.c r_exp.c r_imag.c r_int.c r_lg10.c \ + r_log.c r_mod.c r_nint.c r_sign.c r_sin.c r_sinh.c r_sqrt.c \ + r_tan.c r_tanh.c s_cat.c s_cmp.c s_copy.c \ + s_paus.c s_rnge.c s_stop.c sig_die.c signal1.h0 signal_.c system_.c \ + z_abs.c z_cos.c z_div.c z_exp.c z_log.c z_sin.c z_sqrt.c >zap + cmp zap libF77.xsum && rm zap || diff libF77.xsum zap diff --git a/gcc/f/runtime/libF77/pow_ci.c b/gcc/f/runtime/libF77/pow_ci.c new file mode 100644 index 000000000000..37e2ce0f2eb9 --- /dev/null +++ b/gcc/f/runtime/libF77/pow_ci.c @@ -0,0 +1,20 @@ +#include "f2c.h" + +#ifdef KR_headers +VOID pow_ci(p, a, b) /* p = a**b */ + complex *p, *a; integer *b; +#else +extern void pow_zi(doublecomplex*, doublecomplex*, integer*); +void pow_ci(complex *p, complex *a, integer *b) /* p = a**b */ +#endif +{ +doublecomplex p1, a1; + +a1.r = a->r; +a1.i = a->i; + +pow_zi(&p1, &a1, b); + +p->r = p1.r; +p->i = p1.i; +} diff --git a/gcc/f/runtime/libF77/pow_dd.c b/gcc/f/runtime/libF77/pow_dd.c new file mode 100644 index 000000000000..d0dd0ff27447 --- /dev/null +++ b/gcc/f/runtime/libF77/pow_dd.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double pow(); +double pow_dd(ap, bp) doublereal *ap, *bp; +#else +#undef abs +#include +double pow_dd(doublereal *ap, doublereal *bp) +#endif +{ +return(pow(*ap, *bp) ); +} diff --git a/gcc/f/runtime/libF77/pow_di.c b/gcc/f/runtime/libF77/pow_di.c new file mode 100644 index 000000000000..affed625a911 --- /dev/null +++ b/gcc/f/runtime/libF77/pow_di.c @@ -0,0 +1,35 @@ +#include "f2c.h" + +#ifdef KR_headers +double pow_di(ap, bp) doublereal *ap; integer *bp; +#else +double pow_di(doublereal *ap, integer *bp) +#endif +{ +double pow, x; +integer n; +unsigned long u; + +pow = 1; +x = *ap; +n = *bp; + +if(n != 0) + { + if(n < 0) + { + n = -n; + x = 1/x; + } + for(u = n; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + } +return(pow); +} diff --git a/gcc/f/runtime/libF77/pow_hh.c b/gcc/f/runtime/libF77/pow_hh.c new file mode 100644 index 000000000000..24a019734da1 --- /dev/null +++ b/gcc/f/runtime/libF77/pow_hh.c @@ -0,0 +1,33 @@ +#include "f2c.h" + +#ifdef KR_headers +shortint pow_hh(ap, bp) shortint *ap, *bp; +#else +shortint pow_hh(shortint *ap, shortint *bp) +#endif +{ + shortint pow, x, n; + unsigned u; + + x = *ap; + n = *bp; + + if (n <= 0) { + if (n == 0 || x == 1) + return 1; + if (x != -1) + return x == 0 ? 1/x : 0; + n = -n; + } + u = n; + for(pow = 1; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + return(pow); + } diff --git a/gcc/f/runtime/libF77/pow_ii.c b/gcc/f/runtime/libF77/pow_ii.c new file mode 100644 index 000000000000..84d1c7e0b5ec --- /dev/null +++ b/gcc/f/runtime/libF77/pow_ii.c @@ -0,0 +1,33 @@ +#include "f2c.h" + +#ifdef KR_headers +integer pow_ii(ap, bp) integer *ap, *bp; +#else +integer pow_ii(integer *ap, integer *bp) +#endif +{ + integer pow, x, n; + unsigned long u; + + x = *ap; + n = *bp; + + if (n <= 0) { + if (n == 0 || x == 1) + return 1; + if (x != -1) + return x == 0 ? 1/x : 0; + n = -n; + } + u = n; + for(pow = 1; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + return(pow); + } diff --git a/gcc/f/runtime/libF77/pow_qq.c b/gcc/f/runtime/libF77/pow_qq.c new file mode 100644 index 000000000000..3bc80e05f7f0 --- /dev/null +++ b/gcc/f/runtime/libF77/pow_qq.c @@ -0,0 +1,33 @@ +#include "f2c.h" + +#ifdef KR_headers +longint pow_qq(ap, bp) longint *ap, *bp; +#else +longint pow_qq(longint *ap, longint *bp) +#endif +{ + longint pow, x, n; + unsigned long long u; /* system-dependent */ + + x = *ap; + n = *bp; + + if (n <= 0) { + if (n == 0 || x == 1) + return 1; + if (x != -1) + return x == 0 ? 1/x : 0; + n = -n; + } + u = n; + for(pow = 1; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + return(pow); + } diff --git a/gcc/f/runtime/libF77/pow_ri.c b/gcc/f/runtime/libF77/pow_ri.c new file mode 100644 index 000000000000..6e5816bbf109 --- /dev/null +++ b/gcc/f/runtime/libF77/pow_ri.c @@ -0,0 +1,35 @@ +#include "f2c.h" + +#ifdef KR_headers +double pow_ri(ap, bp) real *ap; integer *bp; +#else +double pow_ri(real *ap, integer *bp) +#endif +{ +double pow, x; +integer n; +unsigned long u; + +pow = 1; +x = *ap; +n = *bp; + +if(n != 0) + { + if(n < 0) + { + n = -n; + x = 1/x; + } + for(u = n; ; ) + { + if(u & 01) + pow *= x; + if(u >>= 1) + x *= x; + else + break; + } + } +return(pow); +} diff --git a/gcc/f/runtime/libF77/pow_zi.c b/gcc/f/runtime/libF77/pow_zi.c new file mode 100644 index 000000000000..898ea6be917b --- /dev/null +++ b/gcc/f/runtime/libF77/pow_zi.c @@ -0,0 +1,61 @@ +#include "f2c.h" + +#ifdef KR_headers +VOID pow_zi(resx, a, b) /* p = a**b */ + doublecomplex *resx, *a; integer *b; +#else +extern void z_div(doublecomplex*, doublecomplex*, doublecomplex*); +void pow_zi(doublecomplex *resx, doublecomplex *a, integer *b) /* p = a**b */ +#endif +{ +integer n; +unsigned long u; +double t; +doublecomplex x; +doublecomplex res; +static doublecomplex one = {1.0, 0.0}; + +n = *b; + +if(n == 0) + { + resx->r = 1; + resx->i = 0; + return; + } + +res.r = 1; +res.i = 0; + +if(n < 0) + { + n = -n; + z_div(&x, &one, a); + } +else + { + x.r = a->r; + x.i = a->i; + } + +for(u = n; ; ) + { + if(u & 01) + { + t = res.r * x.r - res.i * x.i; + res.i = res.r * x.i + res.i * x.r; + res.r = t; + } + if(u >>= 1) + { + t = x.r * x.r - x.i * x.i; + x.i = 2 * x.r * x.i; + x.r = t; + } + else + break; + } + +resx->r = res.r; +resx->i = res.i; +} diff --git a/gcc/f/runtime/libF77/pow_zz.c b/gcc/f/runtime/libF77/pow_zz.c new file mode 100644 index 000000000000..20faf29cfb89 --- /dev/null +++ b/gcc/f/runtime/libF77/pow_zz.c @@ -0,0 +1,23 @@ +#include "f2c.h" + +#ifdef KR_headers +double log(), exp(), cos(), sin(), atan2(), f__cabs(); +VOID pow_zz(r,a,b) doublecomplex *r, *a, *b; +#else +#undef abs +#include +extern double f__cabs(double,double); +void pow_zz(doublecomplex *r, doublecomplex *a, doublecomplex *b) +#endif +{ +double logr, logi, x, y; + +logr = log( f__cabs(a->r, a->i) ); +logi = atan2(a->i, a->r); + +x = exp( logr * b->r - logi * b->i ); +y = logr * b->i + logi * b->r; + +r->r = x * cos(y); +r->i = x * sin(y); +} diff --git a/gcc/f/runtime/libF77/qbitbits.c b/gcc/f/runtime/libF77/qbitbits.c new file mode 100644 index 000000000000..ad4ac963ce20 --- /dev/null +++ b/gcc/f/runtime/libF77/qbitbits.c @@ -0,0 +1,66 @@ +#include "f2c.h" + +#ifndef LONGBITS +#define LONGBITS 32 +#endif + +#ifndef LONG8BITS +#define LONG8BITS (2*LONGBITS) +#endif + + integer +#ifdef KR_headers +qbit_bits(a, b, len) longint a; integer b, len; +#else +qbit_bits(longint a, integer b, integer len) +#endif +{ + /* Assume 2's complement arithmetic */ + + ulongint x, y; + + x = (ulongint) a; + y = (ulongint)-1L; + x >>= b; + y <<= len; + return (longint)(x & y); + } + + longint +#ifdef KR_headers +qbit_cshift(a, b, len) longint a; integer b, len; +#else +qbit_cshift(longint a, integer b, integer len) +#endif +{ + ulongint x, y, z; + + x = (ulongint)a; + if (len <= 0) { + if (len == 0) + return 0; + goto full_len; + } + if (len >= LONG8BITS) { + full_len: + if (b >= 0) { + b %= LONG8BITS; + return (longint)(x << b | x >> LONG8BITS - b ); + } + b = -b; + b %= LONG8BITS; + return (longint)(x << LONG8BITS - b | x >> b); + } + y = z = (unsigned long)-1; + y <<= len; + z &= ~y; + y &= x; + x &= z; + if (b >= 0) { + b %= len; + return (longint)(y | z & (x << b | x >> len - b)); + } + b = -b; + b %= len; + return (longint)(y | z & (x >> b | x << len - b)); + } diff --git a/gcc/f/runtime/libF77/qbitshft.c b/gcc/f/runtime/libF77/qbitshft.c new file mode 100644 index 000000000000..87fffb91ff8e --- /dev/null +++ b/gcc/f/runtime/libF77/qbitshft.c @@ -0,0 +1,11 @@ +#include "f2c.h" + + longint +#ifdef KR_headers +qbit_shift(a, b) longint a; integer b; +#else +qbit_shift(longint a, integer b) +#endif +{ + return b >= 0 ? a << b : (longint)((ulongint)a >> -b); + } diff --git a/gcc/f/runtime/libF77/r_abs.c b/gcc/f/runtime/libF77/r_abs.c new file mode 100644 index 000000000000..7b222961d16d --- /dev/null +++ b/gcc/f/runtime/libF77/r_abs.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +double r_abs(x) real *x; +#else +double r_abs(real *x) +#endif +{ +if(*x >= 0) + return(*x); +return(- *x); +} diff --git a/gcc/f/runtime/libF77/r_acos.c b/gcc/f/runtime/libF77/r_acos.c new file mode 100644 index 000000000000..330f88a30929 --- /dev/null +++ b/gcc/f/runtime/libF77/r_acos.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double acos(); +double r_acos(x) real *x; +#else +#undef abs +#include +double r_acos(real *x) +#endif +{ +return( acos(*x) ); +} diff --git a/gcc/f/runtime/libF77/r_asin.c b/gcc/f/runtime/libF77/r_asin.c new file mode 100644 index 000000000000..45ece4b749e3 --- /dev/null +++ b/gcc/f/runtime/libF77/r_asin.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double asin(); +double r_asin(x) real *x; +#else +#undef abs +#include +double r_asin(real *x) +#endif +{ +return( asin(*x) ); +} diff --git a/gcc/f/runtime/libF77/r_atan.c b/gcc/f/runtime/libF77/r_atan.c new file mode 100644 index 000000000000..36479c915b05 --- /dev/null +++ b/gcc/f/runtime/libF77/r_atan.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double atan(); +double r_atan(x) real *x; +#else +#undef abs +#include +double r_atan(real *x) +#endif +{ +return( atan(*x) ); +} diff --git a/gcc/f/runtime/libF77/r_atn2.c b/gcc/f/runtime/libF77/r_atn2.c new file mode 100644 index 000000000000..9347e1f13a9a --- /dev/null +++ b/gcc/f/runtime/libF77/r_atn2.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double atan2(); +double r_atn2(x,y) real *x, *y; +#else +#undef abs +#include +double r_atn2(real *x, real *y) +#endif +{ +return( atan2(*x,*y) ); +} diff --git a/gcc/f/runtime/libF77/r_cnjg.c b/gcc/f/runtime/libF77/r_cnjg.c new file mode 100644 index 000000000000..b6175eedfd76 --- /dev/null +++ b/gcc/f/runtime/libF77/r_cnjg.c @@ -0,0 +1,16 @@ +#include "f2c.h" + +#ifdef KR_headers +VOID r_cnjg(resx, z) complex *resx, *z; +#else +VOID r_cnjg(complex *resx, complex *z) +#endif +{ +complex res; + +res.r = z->r; +res.i = - z->i; + +resx->r = res.r; +resx->i = res.i; +} diff --git a/gcc/f/runtime/libF77/r_cos.c b/gcc/f/runtime/libF77/r_cos.c new file mode 100644 index 000000000000..5bda158cee95 --- /dev/null +++ b/gcc/f/runtime/libF77/r_cos.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double cos(); +double r_cos(x) real *x; +#else +#undef abs +#include +double r_cos(real *x) +#endif +{ +return( cos(*x) ); +} diff --git a/gcc/f/runtime/libF77/r_cosh.c b/gcc/f/runtime/libF77/r_cosh.c new file mode 100644 index 000000000000..7ae72cc0cef9 --- /dev/null +++ b/gcc/f/runtime/libF77/r_cosh.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double cosh(); +double r_cosh(x) real *x; +#else +#undef abs +#include +double r_cosh(real *x) +#endif +{ +return( cosh(*x) ); +} diff --git a/gcc/f/runtime/libF77/r_dim.c b/gcc/f/runtime/libF77/r_dim.c new file mode 100644 index 000000000000..baca95cd9e47 --- /dev/null +++ b/gcc/f/runtime/libF77/r_dim.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +#ifdef KR_headers +double r_dim(a,b) real *a, *b; +#else +double r_dim(real *a, real *b) +#endif +{ +return( *a > *b ? *a - *b : 0); +} diff --git a/gcc/f/runtime/libF77/r_exp.c b/gcc/f/runtime/libF77/r_exp.c new file mode 100644 index 000000000000..d1dea75563f0 --- /dev/null +++ b/gcc/f/runtime/libF77/r_exp.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double exp(); +double r_exp(x) real *x; +#else +#undef abs +#include +double r_exp(real *x) +#endif +{ +return( exp(*x) ); +} diff --git a/gcc/f/runtime/libF77/r_imag.c b/gcc/f/runtime/libF77/r_imag.c new file mode 100644 index 000000000000..d51252bbb791 --- /dev/null +++ b/gcc/f/runtime/libF77/r_imag.c @@ -0,0 +1,10 @@ +#include "f2c.h" + +#ifdef KR_headers +double r_imag(z) complex *z; +#else +double r_imag(complex *z) +#endif +{ +return(z->i); +} diff --git a/gcc/f/runtime/libF77/r_int.c b/gcc/f/runtime/libF77/r_int.c new file mode 100644 index 000000000000..8378e775726a --- /dev/null +++ b/gcc/f/runtime/libF77/r_int.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +double r_int(x) real *x; +#else +#undef abs +#include +double r_int(real *x) +#endif +{ +return( (*x>0) ? floor(*x) : -floor(- *x) ); +} diff --git a/gcc/f/runtime/libF77/r_lg10.c b/gcc/f/runtime/libF77/r_lg10.c new file mode 100644 index 000000000000..51f842017118 --- /dev/null +++ b/gcc/f/runtime/libF77/r_lg10.c @@ -0,0 +1,15 @@ +#include "f2c.h" + +#define log10e 0.43429448190325182765 + +#ifdef KR_headers +double log(); +double r_lg10(x) real *x; +#else +#undef abs +#include +double r_lg10(real *x) +#endif +{ +return( log10e * log(*x) ); +} diff --git a/gcc/f/runtime/libF77/r_log.c b/gcc/f/runtime/libF77/r_log.c new file mode 100644 index 000000000000..4873fb418e89 --- /dev/null +++ b/gcc/f/runtime/libF77/r_log.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double log(); +double r_log(x) real *x; +#else +#undef abs +#include +double r_log(real *x) +#endif +{ +return( log(*x) ); +} diff --git a/gcc/f/runtime/libF77/r_mod.c b/gcc/f/runtime/libF77/r_mod.c new file mode 100644 index 000000000000..faea344a7b76 --- /dev/null +++ b/gcc/f/runtime/libF77/r_mod.c @@ -0,0 +1,40 @@ +#include "f2c.h" + +#ifdef KR_headers +#ifdef IEEE_drem +double drem(); +#else +double floor(); +#endif +double r_mod(x,y) real *x, *y; +#else +#ifdef IEEE_drem +double drem(double, double); +#else +#undef abs +#include +#endif +double r_mod(real *x, real *y) +#endif +{ +#ifdef IEEE_drem + double xa, ya, z; + if ((ya = *y) < 0.) + ya = -ya; + z = drem(xa = *x, ya); + if (xa > 0) { + if (z < 0) + z += ya; + } + else if (z > 0) + z -= ya; + return z; +#else + double quotient; + if( (quotient = (double)*x / *y) >= 0) + quotient = floor(quotient); + else + quotient = -floor(-quotient); + return(*x - (*y) * quotient ); +#endif +} diff --git a/gcc/f/runtime/libF77/r_nint.c b/gcc/f/runtime/libF77/r_nint.c new file mode 100644 index 000000000000..f5382af660af --- /dev/null +++ b/gcc/f/runtime/libF77/r_nint.c @@ -0,0 +1,14 @@ +#include "f2c.h" + +#ifdef KR_headers +double floor(); +double r_nint(x) real *x; +#else +#undef abs +#include +double r_nint(real *x) +#endif +{ +return( (*x)>=0 ? + floor(*x + .5) : -floor(.5 - *x) ); +} diff --git a/gcc/f/runtime/libF77/r_sign.c b/gcc/f/runtime/libF77/r_sign.c new file mode 100644 index 000000000000..df6d02af00a7 --- /dev/null +++ b/gcc/f/runtime/libF77/r_sign.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +double r_sign(a,b) real *a, *b; +#else +double r_sign(real *a, real *b) +#endif +{ +double x; +x = (*a >= 0 ? *a : - *a); +return( *b >= 0 ? x : -x); +} diff --git a/gcc/f/runtime/libF77/r_sin.c b/gcc/f/runtime/libF77/r_sin.c new file mode 100644 index 000000000000..095b9510de90 --- /dev/null +++ b/gcc/f/runtime/libF77/r_sin.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double sin(); +double r_sin(x) real *x; +#else +#undef abs +#include +double r_sin(real *x) +#endif +{ +return( sin(*x) ); +} diff --git a/gcc/f/runtime/libF77/r_sinh.c b/gcc/f/runtime/libF77/r_sinh.c new file mode 100644 index 000000000000..3bf4bb138be9 --- /dev/null +++ b/gcc/f/runtime/libF77/r_sinh.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double sinh(); +double r_sinh(x) real *x; +#else +#undef abs +#include +double r_sinh(real *x) +#endif +{ +return( sinh(*x) ); +} diff --git a/gcc/f/runtime/libF77/r_sqrt.c b/gcc/f/runtime/libF77/r_sqrt.c new file mode 100644 index 000000000000..d0203d3d19bd --- /dev/null +++ b/gcc/f/runtime/libF77/r_sqrt.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double sqrt(); +double r_sqrt(x) real *x; +#else +#undef abs +#include +double r_sqrt(real *x) +#endif +{ +return( sqrt(*x) ); +} diff --git a/gcc/f/runtime/libF77/r_tan.c b/gcc/f/runtime/libF77/r_tan.c new file mode 100644 index 000000000000..fc0009e4774d --- /dev/null +++ b/gcc/f/runtime/libF77/r_tan.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double tan(); +double r_tan(x) real *x; +#else +#undef abs +#include +double r_tan(real *x) +#endif +{ +return( tan(*x) ); +} diff --git a/gcc/f/runtime/libF77/r_tanh.c b/gcc/f/runtime/libF77/r_tanh.c new file mode 100644 index 000000000000..818c6a8451bf --- /dev/null +++ b/gcc/f/runtime/libF77/r_tanh.c @@ -0,0 +1,13 @@ +#include "f2c.h" + +#ifdef KR_headers +double tanh(); +double r_tanh(x) real *x; +#else +#undef abs +#include +double r_tanh(real *x) +#endif +{ +return( tanh(*x) ); +} diff --git a/gcc/f/runtime/libF77/s_cat.c b/gcc/f/runtime/libF77/s_cat.c new file mode 100644 index 000000000000..f462fd24945d --- /dev/null +++ b/gcc/f/runtime/libF77/s_cat.c @@ -0,0 +1,75 @@ +/* Unless compiled with -DNO_OVERWRITE, this variant of s_cat allows the + * target of a concatenation to appear on its right-hand side (contrary + * to the Fortran 77 Standard, but in accordance with Fortran 90). + */ + +#include "f2c.h" +#ifndef NO_OVERWRITE +#include +#undef abs +#ifdef KR_headers + extern char *F77_aloc(); + extern void free(); + extern void G77_exit_0 (); +#else +#undef min +#undef max +#include + extern char *F77_aloc(ftnlen, char*); +#endif +#include +#endif /* NO_OVERWRITE */ + + VOID +#ifdef KR_headers +s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnlen rnp[], *np, ll; +#else +s_cat(char *lp, char *rpp[], ftnlen rnp[], ftnlen *np, ftnlen ll) +#endif +{ + ftnlen i, nc; + char *rp; + ftnlen n = *np; +#ifndef NO_OVERWRITE + ftnlen L, m; + char *lp0, *lp1; + + lp0 = 0; + lp1 = lp; + L = ll; + i = 0; + while(i < n) { + rp = rpp[i]; + m = rnp[i++]; + if (rp >= lp1 || rp + m <= lp) { + if ((L -= m) <= 0) { + n = i; + break; + } + lp1 += m; + continue; + } + lp0 = lp; + lp = lp1 = F77_aloc(L = ll, "s_cat"); + break; + } + lp1 = lp; +#endif /* NO_OVERWRITE */ + for(i = 0 ; i < n ; ++i) { + nc = ll; + if(rnp[i] < nc) + nc = rnp[i]; + ll -= nc; + rp = rpp[i]; + while(--nc >= 0) + *lp++ = *rp++; + } + while(--ll >= 0) + *lp++ = ' '; +#ifndef NO_OVERWRITE + if (lp0) { + memcpy(lp0, lp1, L); + free(lp1); + } +#endif + } diff --git a/gcc/f/runtime/libF77/s_cmp.c b/gcc/f/runtime/libF77/s_cmp.c new file mode 100644 index 000000000000..1e052f286426 --- /dev/null +++ b/gcc/f/runtime/libF77/s_cmp.c @@ -0,0 +1,44 @@ +#include "f2c.h" + +/* compare two strings */ + +#ifdef KR_headers +integer s_cmp(a0, b0, la, lb) char *a0, *b0; ftnlen la, lb; +#else +integer s_cmp(char *a0, char *b0, ftnlen la, ftnlen lb) +#endif +{ +register unsigned char *a, *aend, *b, *bend; +a = (unsigned char *)a0; +b = (unsigned char *)b0; +aend = a + la; +bend = b + lb; + +if(la <= lb) + { + while(a < aend) + if(*a != *b) + return( *a - *b ); + else + { ++a; ++b; } + + while(b < bend) + if(*b != ' ') + return( ' ' - *b ); + else ++b; + } + +else + { + while(b < bend) + if(*a == *b) + { ++a; ++b; } + else + return( *a - *b ); + while(a < aend) + if(*a != ' ') + return(*a - ' '); + else ++a; + } +return(0); +} diff --git a/gcc/f/runtime/libF77/s_copy.c b/gcc/f/runtime/libF77/s_copy.c new file mode 100644 index 000000000000..d1673510c62b --- /dev/null +++ b/gcc/f/runtime/libF77/s_copy.c @@ -0,0 +1,51 @@ +/* Unless compiled with -DNO_OVERWRITE, this variant of s_copy allows the + * target of an assignment to appear on its right-hand side (contrary + * to the Fortran 77 Standard, but in accordance with Fortran 90), + * as in a(2:5) = a(4:7) . + */ + +#include "f2c.h" + +/* assign strings: a = b */ + +#ifdef KR_headers +VOID s_copy(a, b, la, lb) register char *a, *b; ftnlen la, lb; +#else +void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb) +#endif +{ + register char *aend, *bend; + + aend = a + la; + + if(la <= lb) +#ifndef NO_OVERWRITE + if (a <= b || a >= b + la) +#endif + while(a < aend) + *a++ = *b++; +#ifndef NO_OVERWRITE + else + for(b += la; a < aend; ) + *--aend = *--b; +#endif + + else { + bend = b + lb; +#ifndef NO_OVERWRITE + if (a <= b || a >= bend) +#endif + while(b < bend) + *a++ = *b++; +#ifndef NO_OVERWRITE + else { + a += lb; + while(b < bend) + *--a = *--bend; + a += lb; + } +#endif + while(a < aend) + *a++ = ' '; + } + } diff --git a/gcc/f/runtime/libF77/s_paus.c b/gcc/f/runtime/libF77/s_paus.c new file mode 100644 index 000000000000..1317008cb734 --- /dev/null +++ b/gcc/f/runtime/libF77/s_paus.c @@ -0,0 +1,88 @@ +#include +#include "f2c.h" +#define PAUSESIG 15 + +#ifdef KR_headers +#define Void /* void */ +#define Int /* int */ +#else +#define Void void +#define Int int +#undef abs +#undef min +#undef max +#include +#include "signal1.h" +#ifdef __cplusplus +extern "C" { +#endif +extern int getpid(void), isatty(int), pause(void); +#endif + +extern VOID f_exit(Void); + + static VOID +waitpause(Int n) +{ n = n; /* shut up compiler warning */ + return; + } + + static VOID +#ifdef KR_headers +s_1paus(fin) FILE *fin; +#else +s_1paus(FILE *fin) +#endif +{ + fprintf(stderr, + "To resume execution, type go. Other input will terminate the job.\n"); + fflush(stderr); + if( getc(fin)!='g' || getc(fin)!='o' || getc(fin)!='\n' ) { + fprintf(stderr, "STOP\n"); +#ifdef NO_ONEXIT + f_exit(); +#endif + exit(0); + } + } + + int +#ifdef KR_headers +s_paus(s, n) char *s; ftnlen n; +#else +s_paus(char *s, ftnlen n) +#endif +{ + fprintf(stderr, "PAUSE "); + if(n > 0) + fprintf(stderr, " %.*s", (int)n, s); + fprintf(stderr, " statement executed\n"); + if( isatty(fileno(stdin)) ) + s_1paus(stdin); + else { +#if (defined (MSDOS) && !defined (GO32)) || defined(__CYGWIN32__) + FILE *fin; + fin = fopen("con", "r"); + if (!fin) { + fprintf(stderr, "s_paus: can't open con!\n"); + fflush(stderr); + exit(1); + } + s_1paus(fin); + fclose(fin); +#else + fprintf(stderr, + "To resume execution, execute a kill -%d %d command\n", + PAUSESIG, getpid() ); + signal1(PAUSESIG, waitpause); + fflush(stderr); + pause(); +#endif + } + fprintf(stderr, "Execution resumes after PAUSE.\n"); + fflush(stderr); + return 0; /* NOT REACHED */ +#ifdef __cplusplus + } +#endif +} diff --git a/gcc/f/runtime/libF77/s_rnge.c b/gcc/f/runtime/libF77/s_rnge.c new file mode 100644 index 000000000000..189b5247ced2 --- /dev/null +++ b/gcc/f/runtime/libF77/s_rnge.c @@ -0,0 +1,26 @@ +#include +#include "f2c.h" + +/* called when a subscript is out of range */ + +#ifdef KR_headers +extern VOID sig_die(); +integer s_rnge(varn, offset, procn, line) char *varn, *procn; ftnint offset, line; +#else +extern VOID sig_die(char*,int); +integer s_rnge(char *varn, ftnint offset, char *procn, ftnint line) +#endif +{ +register int i; + +fprintf(stderr, "Subscript out of range on file line %ld, procedure ", line); +while((i = *procn) && i != '_' && i != ' ') + putc(*procn++, stderr); +fprintf(stderr, ".\nAttempt to access the %ld-th element of variable ", offset+1); +while((i = *varn) && i != ' ') + putc(*varn++, stderr); +sig_die(".", 1); +#ifdef __cplusplus +return 0; +#endif +} diff --git a/gcc/f/runtime/libF77/s_stop.c b/gcc/f/runtime/libF77/s_stop.c new file mode 100644 index 000000000000..2e3f1035b308 --- /dev/null +++ b/gcc/f/runtime/libF77/s_stop.c @@ -0,0 +1,37 @@ +#include +#include "f2c.h" + +#ifdef KR_headers +extern void f_exit(); +VOID s_stop(s, n) char *s; ftnlen n; +#else +#undef abs +#undef min +#undef max +#include +#ifdef __cplusplus +extern "C" { +#endif +void f_exit(void); + +int s_stop(char *s, ftnlen n) +#endif +{ +int i; + +if(n > 0) + { + fprintf(stderr, "STOP "); + for(i = 0; i +#include + +#ifndef SIGIOT +#ifdef SIGABRT +#define SIGIOT SIGABRT +#endif +#endif + +#ifdef KR_headers +void sig_die(s, kill) register char *s; int kill; +#else +#include +#ifdef __cplusplus +extern "C" { +#endif + extern void f_exit(void); + +void sig_die(register char *s, int kill) +#endif +{ + /* print error message, then clear buffers */ + fprintf(stderr, "%s\n", s); + + if(kill) + { + fflush(stderr); + f_exit(); + fflush(stderr); + /* now get a core */ +#ifdef SIGIOT + signal(SIGIOT, SIG_DFL); +#endif + abort(); + } + else { +#ifdef NO_ONEXIT + f_exit(); +#endif + exit(1); + } + } +#ifdef __cplusplus +} +#endif diff --git a/gcc/f/runtime/libF77/signal1.h b/gcc/f/runtime/libF77/signal1.h new file mode 100644 index 000000000000..b559211e8e4a --- /dev/null +++ b/gcc/f/runtime/libF77/signal1.h @@ -0,0 +1,5 @@ +/* The g77 implementation of libf2c directly includes signal1.h0, + instead of copying it to signal1.h, since that seems easier to + cope with at this point. */ + +#include "signal1.h0" diff --git a/gcc/f/runtime/libF77/signal1.h0 b/gcc/f/runtime/libF77/signal1.h0 new file mode 100644 index 000000000000..8800a18d77b4 --- /dev/null +++ b/gcc/f/runtime/libF77/signal1.h0 @@ -0,0 +1,25 @@ +/* You may need to adjust the definition of signal1 to supply a */ +/* cast to the correct argument type. This detail is system- and */ +/* compiler-dependent. The #define below assumes signal.h declares */ +/* type SIG_PF for the signal function's second argument. */ + +#include + +#ifndef Sigret_t +#define Sigret_t void +#endif +#ifndef Sigarg_t +#ifdef KR_headers +#define Sigarg_t +#else +#define Sigarg_t int +#endif +#endif /*Sigarg_t*/ + +#ifdef USE_SIG_PF /* compile with -DUSE_SIG_PF under IRIX */ +#define sig_pf SIG_PF +#else +typedef Sigret_t (*sig_pf)(Sigarg_t); +#endif + +#define signal1(a,b) signal(a,(sig_pf)b) diff --git a/gcc/f/runtime/libF77/signal_.c b/gcc/f/runtime/libF77/signal_.c new file mode 100644 index 000000000000..1ac81391aeff --- /dev/null +++ b/gcc/f/runtime/libF77/signal_.c @@ -0,0 +1,14 @@ +#include "f2c.h" +#include "signal1.h" + +#ifdef KR_headers +ftnint G77_signal_0 (sigp, proc) integer *sigp; sig_pf proc; +#else +ftnint G77_signal_0 (integer *sigp, sig_pf proc) +#endif +{ + int sig; + sig = (int)*sigp; + + return (ftnint)signal(sig, proc); + } diff --git a/gcc/f/runtime/libF77/system_.c b/gcc/f/runtime/libF77/system_.c new file mode 100644 index 000000000000..ed024a14ded5 --- /dev/null +++ b/gcc/f/runtime/libF77/system_.c @@ -0,0 +1,36 @@ +/* f77 interface to system routine */ + +#include "f2c.h" + +#ifdef KR_headers +extern char *F77_aloc(); + + integer +G77_system_0 (s, n) register char *s; ftnlen n; +#else +#undef abs +#undef min +#undef max +#include +extern char *F77_aloc(ftnlen, char*); + + integer +G77_system_0 (register char *s, ftnlen n) +#endif +{ + char buff0[256], *buff; + register char *bp, *blast; + integer rv; + + buff = bp = n < sizeof(buff0) + ? buff0 : F77_aloc(n+1, "system_"); + blast = bp + n; + + while(bp < blast && *s) + *bp++ = *s++; + *bp = 0; + rv = system(buff); + if (buff != buff0) + free(buff); + return rv; + } diff --git a/gcc/f/runtime/libF77/z_abs.c b/gcc/f/runtime/libF77/z_abs.c new file mode 100644 index 000000000000..7e67ad2957fb --- /dev/null +++ b/gcc/f/runtime/libF77/z_abs.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +#ifdef KR_headers +double f__cabs(); +double z_abs(z) doublecomplex *z; +#else +double f__cabs(double, double); +double z_abs(doublecomplex *z) +#endif +{ +return( f__cabs( z->r, z->i ) ); +} diff --git a/gcc/f/runtime/libF77/z_cos.c b/gcc/f/runtime/libF77/z_cos.c new file mode 100644 index 000000000000..a811bbecc65b --- /dev/null +++ b/gcc/f/runtime/libF77/z_cos.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sin(), cos(), sinh(), cosh(); +VOID z_cos(resx, z) doublecomplex *resx, *z; +#else +#undef abs +#include +void z_cos(doublecomplex *resx, doublecomplex *z) +#endif +{ +doublecomplex res; + +res.r = cos(z->r) * cosh(z->i); +res.i = - sin(z->r) * sinh(z->i); + +resx->r = res.r; +resx->i = res.i; +} diff --git a/gcc/f/runtime/libF77/z_div.c b/gcc/f/runtime/libF77/z_div.c new file mode 100644 index 000000000000..4a987ab255a4 --- /dev/null +++ b/gcc/f/runtime/libF77/z_div.c @@ -0,0 +1,39 @@ +#include "f2c.h" + +#ifdef KR_headers +extern VOID sig_die(); +VOID z_div(resx, a, b) doublecomplex *a, *b, *resx; +#else +extern void sig_die(char*, int); +void z_div(doublecomplex *resx, doublecomplex *a, doublecomplex *b) +#endif +{ +double ratio, den; +double abr, abi; +doublecomplex res; + +if( (abr = b->r) < 0.) + abr = - abr; +if( (abi = b->i) < 0.) + abi = - abi; +if( abr <= abi ) + { + if(abi == 0) + sig_die("complex division by zero", 1); + ratio = b->r / b->i ; + den = b->i * (1 + ratio*ratio); + res.r = (a->r*ratio + a->i) / den; + res.i = (a->i*ratio - a->r) / den; + } + +else + { + ratio = b->i / b->r ; + den = b->r * (1 + ratio*ratio); + res.r = (a->r + a->i*ratio) / den; + res.i = (a->i - a->r*ratio) / den; + } + +resx->r = res.r; +resx->i = res.i; +} diff --git a/gcc/f/runtime/libF77/z_exp.c b/gcc/f/runtime/libF77/z_exp.c new file mode 100644 index 000000000000..85fb63e42095 --- /dev/null +++ b/gcc/f/runtime/libF77/z_exp.c @@ -0,0 +1,21 @@ +#include "f2c.h" + +#ifdef KR_headers +double exp(), cos(), sin(); +VOID z_exp(resx, z) doublecomplex *resx, *z; +#else +#undef abs +#include +void z_exp(doublecomplex *resx, doublecomplex *z) +#endif +{ +double expx; +doublecomplex res; + +expx = exp(z->r); +res.r = expx * cos(z->i); +res.i = expx * sin(z->i); + +resx->r = res.r; +resx->i = res.i; +} diff --git a/gcc/f/runtime/libF77/z_log.c b/gcc/f/runtime/libF77/z_log.c new file mode 100644 index 000000000000..48afca63d6d6 --- /dev/null +++ b/gcc/f/runtime/libF77/z_log.c @@ -0,0 +1,20 @@ +#include "f2c.h" + +#ifdef KR_headers +double log(), f__cabs(), atan2(); +VOID z_log(resx, z) doublecomplex *resx, *z; +#else +#undef abs +#include +extern double f__cabs(double, double); +void z_log(doublecomplex *resx, doublecomplex *z) +#endif +{ +doublecomplex res; + +res.i = atan2(z->i, z->r); +res.r = log( f__cabs( z->r, z->i ) ); + +resx->r = res.r; +resx->i = res.i; +} diff --git a/gcc/f/runtime/libF77/z_sin.c b/gcc/f/runtime/libF77/z_sin.c new file mode 100644 index 000000000000..94456c9c30a3 --- /dev/null +++ b/gcc/f/runtime/libF77/z_sin.c @@ -0,0 +1,19 @@ +#include "f2c.h" + +#ifdef KR_headers +double sin(), cos(), sinh(), cosh(); +VOID z_sin(resx, z) doublecomplex *resx, *z; +#else +#undef abs +#include +void z_sin(doublecomplex *resx, doublecomplex *z) +#endif +{ +doublecomplex res; + +res.r = sin(z->r) * cosh(z->i); +res.i = cos(z->r) * sinh(z->i); + +resx->r = res.r; +resx->i = res.i; +} diff --git a/gcc/f/runtime/libF77/z_sqrt.c b/gcc/f/runtime/libF77/z_sqrt.c new file mode 100644 index 000000000000..f5db56519911 --- /dev/null +++ b/gcc/f/runtime/libF77/z_sqrt.c @@ -0,0 +1,33 @@ +#include "f2c.h" + +#ifdef KR_headers +double sqrt(), f__cabs(); +VOID z_sqrt(resx, z) doublecomplex *resx, *z; +#else +#undef abs +#include +extern double f__cabs(double, double); +void z_sqrt(doublecomplex *resx, doublecomplex *z) +#endif +{ +double mag; +doublecomplex res; + +if( (mag = f__cabs(z->r, z->i)) == 0.) + res.r = res.i = 0.; +else if(z->r > 0) + { + res.r = sqrt(0.5 * (mag + z->r) ); + res.i = z->i / res.r / 2; + } +else + { + res.i = sqrt(0.5 * (mag - z->r) ); + if(z->i < 0) + res.i = - res.i; + res.r = z->i / res.i / 2; + } + +resx->r = res.r; +resx->i = res.i; +} diff --git a/gcc/f/runtime/libI77/Makefile.in b/gcc/f/runtime/libI77/Makefile.in new file mode 100644 index 000000000000..34bc5fa39975 --- /dev/null +++ b/gcc/f/runtime/libI77/Makefile.in @@ -0,0 +1,129 @@ +# Makefile for GNU F77 compiler runtime. +# Copyright 1990 - 1994 by AT&T Bell Laboratories and Bellcore (see the +# file `Notice'). +# Portions of this file Copyright (C) 1995, 1996 Free Software Foundation, Inc. +# Contributed by Dave Love (d.love@dl.ac.uk). +# +#This file is part of GNU Fortran. +# +#GNU Fortran is free software; you can redistribute it and/or modify +#it under the terms of the GNU General Public License as published by +#the Free Software Foundation; either version 2, or (at your option) +#any later version. +# +#GNU Fortran is distributed in the hope that it will be useful, +#but WITHOUT ANY WARRANTY; without even the implied warranty of +#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +#GNU General Public License for more details. +# +#You should have received a copy of the GNU General Public License +#along with GNU Fortran; see the file COPYING. If not, write to +#the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +#02111-1307, USA. + +SHELL = /bin/sh + +srcdir = @srcdir@ +VPATH = @srcdir@ + +#### Start of system configuration section. #### + +# The _FOR_TARGET things are appropriate for a cross-make, passed by the +# superior makefile +GCC_FOR_TARGET = @CC@ +CC = $(GCC_FOR_TARGET) +CFLAGS = @CFLAGS@ $(GCC_FLAGS) +CPPFLAGS = @CPPFLAGS@ +DEFS = @DEFS@ +CGFLAGS = -g0 +# f2c.h should already be installed in xgcc's include directory but add that +# to -I anyhow in case not using xgcc. +ALL_CFLAGS = -I. -I$(srcdir) -I../../../include $(CPPFLAGS) $(DEFS) $(CFLAGS) +AR = @AR@ +AR_FLAGS = rc +RANLIB = @RANLIB@ +RANLIB_TEST = @RANLIB_TEST@ +CROSS = @CROSS@ + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $(CC) -c -DSkip_f2c_Undefs -DAllow_TYQUAD $(ALL_CFLAGS) $(CGFLAGS) $< + +OBJ = VersionI.o backspace.o close.o dfe.o dolio.o due.o endfile.o err.o \ + fmt.o fmtlib.o iio.o ilnw.o inquire.o lread.o lwrite.o open.o \ + rdfmt.o rewind.o rsfe.o rsli.o rsne.o sfe.o sue.o typesize.o uio.o \ + util.o wref.o wrtfmt.o wsfe.o wsle.o wsne.o xwsne.o \ + ftell_.o + +F2C_H = ../../../include/f2c.h + +all: $(OBJ) + +VersionI.o: Version.c + $(CC) -c $(CGFLAGS) -o $@ $(srcdir)/Version.c + +mostlyclean clean: + -rm -f $(OBJ) + +distclean maintainer-clean: mostlyclean + -rm -f stage? include Makefile + +backspace.o: fio.h +close.o: fio.h +dfe.o: fio.h +dfe.o: fmt.h +due.o: fio.h +endfile.o: fio.h rawio.h +err.o: fio.h rawio.h +fmt.o: fio.h +fmt.o: fmt.h +ftell_.o: fio.h +iio.o: fio.h +iio.o: fmt.h +ilnw.o: fio.h +ilnw.o: lio.h +inquire.o: fio.h +lread.o: fio.h +lread.o: fmt.h +lread.o: lio.h +lread.o: fp.h +lwrite.o: fio.h +lwrite.o: fmt.h +lwrite.o: lio.h +open.o: fio.h rawio.h +rdfmt.o: fio.h +rdfmt.o: fmt.h +rdfmt.o: fp.h +rewind.o: fio.h +rsfe.o: fio.h +rsfe.o: fmt.h +rsli.o: fio.h +rsli.o: lio.h +rsne.o: fio.h +rsne.o: lio.h +sfe.o: fio.h +sue.o: fio.h +uio.o: fio.h +util.o: fio.h +wref.o: fio.h +wref.o: fmt.h +wref.o: fp.h +wrtfmt.o: fio.h +wrtfmt.o: fmt.h +wsfe.o: fio.h +wsfe.o: fmt.h +wsle.o: fio.h +wsle.o: fmt.h +wsle.o: lio.h +wsne.o: fio.h +wsne.o: lio.h +xwsne.o: fio.h +xwsne.o: lio.h +xwsne.o: fmt.h + +# May be pessimistic: +$(OBJ): $(F2C_H) + +.PHONY: mostlyclean clean distclean maintainer-clean all diff --git a/gcc/f/runtime/libI77/Notice b/gcc/f/runtime/libI77/Notice new file mode 100644 index 000000000000..261b719bc57e --- /dev/null +++ b/gcc/f/runtime/libI77/Notice @@ -0,0 +1,23 @@ +/**************************************************************** +Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + diff --git a/gcc/f/runtime/libI77/README.netlib b/gcc/f/runtime/libI77/README.netlib new file mode 100644 index 000000000000..30dd5b5223dc --- /dev/null +++ b/gcc/f/runtime/libI77/README.netlib @@ -0,0 +1,225 @@ +If your compiler does not recognize ANSI C headers, +compile with KR_headers defined: either add -DKR_headers +to the definition of CFLAGS in the makefile, or insert + +#define KR_headers + +at the top of f2c.h and fmtlib.c . + + +If you have a really ancient K&R C compiler that does not understand +void, add -Dvoid=int to the definition of CFLAGS in the makefile. + +If you use a C++ compiler, first create a local f2c.h by appending +f2ch.add to the usual f2c.h, e.g., by issuing the command + make f2c.h +which assumes f2c.h is installed in /usr/include . + +If your system lacks /usr/include/fcntl.h , then you +should simply create an empty fcntl.h in this directory. +If your compiler then complains about creat and open not +having a prototype, compile with OPEN_DECL defined. +On many systems, open and creat are declared in fcntl.h . + +If your system has /usr/include/fcntl.h, you may need to add +-D_POSIX_SOURCE to the makefile's definition of CFLAGS. + +If your system's sprintf does not work the way ANSI C +specifies -- specifically, if it does not return the +number of characters transmitted -- then insert the line + +#define USE_STRLEN + +at the end of fmt.h . This is necessary with +at least some versions of Sun and DEC software. +In particular, if you get a warning about an improper +pointer/integer combination in compiling wref.c, then +you need to compile with -DUSE_STRLEN . + +If your system's fopen does not like the ANSI binary +reading and writing modes "rb" and "wb", then you should +compile open.c with NON_ANSI_RW_MODES #defined. + +If you get error messages about references to cf->_ptr +and cf->_base when compiling wrtfmt.c and wsfe.c or to +stderr->_flag when compiling err.c, then insert the line + +#define NON_UNIX_STDIO + +at the beginning of fio.h, and recompile everything (or +at least those modules that contain NON_UNIX_STDIO). + +Unformatted sequential records consist of a length of record +contents, the record contents themselves, and the length of +record contents again (for backspace). Prior to 17 Oct. 1991, +the length was of type int; now it is of type long, but you +can change it back to int by inserting + +#define UIOLEN_int + +at the beginning of fio.h. This affects only sue.c and uio.c . + +On VAX, Cray, or Research Tenth-Edition Unix systems, you may +need to add -DVAX, -DCRAY, or -DV10 (respectively) to CFLAGS +to make fp.h work correctly. Alternatively, you may need to +edit fp.h to suit your machine. + +You may need to supply the following non-ANSI routines: + + fstat(int fileds, struct stat *buf) is similar +to stat(char *name, struct stat *buf), except that +the first argument, fileds, is the file descriptor +returned by open rather than the name of the file. +fstat is used in the system-dependent routine +canseek (in the libI77 source file err.c), which +is supposed to return 1 if it's possible to issue +seeks on the file in question, 0 if it's not; you may +need to suitably modify err.c . On non-UNIX systems, +you can avoid references to fstat and stat by compiling +with NON_UNIX_STDIO defined; in that case, you may need +to supply access(char *Name,0), which is supposed to +return 0 if file Name exists, nonzero otherwise. + + char * mktemp(char *buf) is supposed to replace the +6 trailing X's in buf with a unique number and then +return buf. The idea is to get a unique name for +a temporary file. + +On non-UNIX systems, you may need to change a few other, +e.g.: the form of name computed by mktemp() in endfile.c and +open.c; the use of the open(), close(), and creat() system +calls in endfile.c, err.c, open.c; and the modes in calls on +fopen() and fdopen() (and perhaps the use of fdopen() itself +-- it's supposed to return a FILE* corresponding to a given +an integer file descriptor) in err.c and open.c (component ufmt +of struct unit is 1 for formatted I/O -- text mode on some systems +-- and 0 for unformatted I/O -- binary mode on some systems). +Compiling with -DNON_UNIX_STDIO omits all references to creat() +and almost all references to open() and close(), the exception +being in the function f__isdev() (in open.c). + +For MS-DOS, compile all of libI77 with -DMSDOS (which implies +-DNON_UNIX_STDIO). You may need to make other compiler-dependent +adjustments; for example, for Turbo C++ you need to adjust the mktemp +invocations and to #undef ungetc in lread.c and rsne.c . + +If you want to be able to load against libI77 but not libF77, +then you will need to add sig_die.o (from libF77) to libI77. + +If you wish to use translated Fortran that has funny notions +of record length for direct unformatted I/O (i.e., that assumes +RECL= values in OPEN statements are not bytes but rather counts +of some other units -- e.g., 4-character words for VMS), then you +should insert an appropriate #define for url_Adjust at the +beginning of open.c . For VMS Fortran, for example, +#define url_Adjust(x) x *= 4 +would suffice. + +To check for transmission errors, issue the command + make check +This assumes you have the xsum program whose source, xsum.c, +is distributed as part of "all from f2c/src". If you do not +have xsum, you can obtain xsum.c by sending the following E-mail +message to netlib@netlib.bell-labs.com + send xsum.c from f2c/src + +The makefile assumes you have installed f2c.h in a standard +place (and does not cause recompilation when f2c.h is changed); +f2c.h comes with "all from f2c" (the source for f2c) and is +available separately ("f2c.h from f2c"). + +By default, Fortran I/O units 5, 6, and 0 are pre-connected to +stdin, stdout, and stderr, respectively. You can change this +behavior by changing f_init() in err.c to suit your needs. +Note that f2c assumes READ(*... means READ(5... and WRITE(*... +means WRITE(6... . Moreover, an OPEN(n,... statement that does +not specify a file name (and does not specify STATUS='SCRATCH') +assumes FILE='fort.n' . You can change this by editing open.c +and endfile.c suitably. + +Unless you adjust the "#define MXUNIT" line in fio.h, Fortran units +0, 1, ..., 99 are available, i.e., the highest allowed unit number +is MXUNIT - 1. + +Lines protected from compilation by #ifdef Allow_TYQUAD +are for a possible extension to 64-bit integers in which +integer = int = 32 bits and longint = long = 64 bits. + +Extensions (Feb. 1993) to NAMELIST processing: + 1. Reading a ? instead of &name (the start of a namelist) causes +the namelist being sought to be written to stdout (unit 6); +to omit this feature, compile rsne.c with -DNo_Namelist_Questions. + 2. Reading the wrong namelist name now leads to an error message +and an attempt to skip input until the right namelist name is found; +to omit this feature, compile rsne.c with -DNo_Bad_Namelist_Skip. + 3. Namelist writes now insert newlines before each variable; to omit +this feature, compile xwsne.c with -DNo_Extra_Namelist_Newlines. + 4. (Sept. 1995) When looking for the &name that starts namelist +input, lines whose first non-blank character is something other +than &, $, or ? are treated as comment lines and ignored, unless +rsne.c is compiled with -DNo_Namelist_Comments. + +Nonstandard extension (Feb. 1993) to open: for sequential files, +ACCESS='APPEND' (or access='anything else starting with "A" or "a"') +causes the file to be positioned at end-of-file, so a write will +append to the file. + +Some buggy Fortran programs use unformatted direct I/O to write +an incomplete record and later read more from that record than +they have written. For records other than the last, the unwritten +portion of the record reads as binary zeros. The last record is +a special case: attempting to read more from it than was written +gives end-of-file -- which may help one find a bug. Some other +Fortran I/O libraries treat the last record no differently than +others and thus give no help in finding the bug of reading more +than was written. If you wish to have this behavior, compile +uio.c with -DPad_UDread . + +If you want to be able to catch write failures (e.g., due to a +disk being full) with an ERR= specifier, compile dfe.c, due.c, +sfe.c, sue.c, and wsle.c with -DALWAYS_FLUSH. This will lead to +slower execution and more I/O, but should make ERR= work as +expected, provided fflush returns an error return when its +physical write fails. + +Carriage controls are meant to be interpreted by the UNIX col +program (or a similar program). Sometimes it's convenient to use +only ' ' as the carriage control character (normal single spacing). +If you compile lwrite.c and wsfe.c with -DOMIT_BLANK_CC, formatted +external output lines will have an initial ' ' quietly omitted, +making use of the col program unnecessary with output that only +has ' ' for carriage control. + +The Fortran 77 Standard leaves it up to the implementation whether +formatted writes of floating-point numbers of absolute value < 1 have +a zero before the decimal point. By default, libI77 omits such +superfluous zeros, but you can cause them to appear by compiling +lwrite.c, wref.c, and wrtfmt.c with -DWANT_LEAD_0 . + +If your system lacks a ranlib command, you don't need it. +Either comment out the makefile's ranlib invocation, or install +a harmless "ranlib" command somewhere in your PATH, such as the +one-line shell script + + exit 0 + +or (on some systems) + + exec /usr/bin/ar lts $1 >/dev/null + +Most of the routines in libI77 are support routines for Fortran +I/O. There are a few exceptions, summarized below -- I/O related +functions and subroutines that appear to your program as ordinary +external Fortran routines. + +1. CALL FLUSH flushes all buffers. + +2. FTELL(i) is an INTEGER function that returns the current + offset of Fortran unit i (or -1 if unit i is not open). + +3. CALL FSEEK(i, offset, whence, *errlab) attemps to move + Fortran unit i to the specified offset: absolute offset + if whence = 0; relative to the current offset if whence = 1; + relative to the end of the file if whence = 2. It branches + to label errlab if unit i is not open or if the call + otherwise fails. diff --git a/gcc/f/runtime/libI77/Version.c b/gcc/f/runtime/libI77/Version.c new file mode 100644 index 000000000000..36d4043c056a --- /dev/null +++ b/gcc/f/runtime/libI77/Version.c @@ -0,0 +1,272 @@ +static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 19970805\n"; + +/* +*/ + +char __G77_LIBI77_VERSION__[] = "0.5.21-19970811"; + +/* +2.01 $ format added +2.02 Coding bug in open.c repaired +2.03 fixed bugs in lread.c (read * with negative f-format) and lio.c + and lio.h (e-format conforming to spec) +2.04 changed open.c and err.c (fopen and freopen respectively) to + update to new c-library (append mode) +2.05 added namelist capability +2.06 allow internal list and namelist I/O +*/ + +/* +close.c: + allow upper-case STATUS= values +endfile.c + create fort.nnn if unit nnn not open; + else if (file length == 0) use creat() rather than copy; + use local copy() rather than forking /bin/cp; + rewind, fseek to clear buffer (for no reading past EOF) +err.c + use neither setbuf nor setvbuf; make stderr buffered +fio.h + #define _bufend +inquire.c + upper case responses; + omit byfile test from SEQUENTIAL= + answer "YES" to DIRECT= for unopened file (open to debate) +lio.c + flush stderr, stdout at end of each stmt + space before character strings in list output only at line start +lio.h + adjust LEW, LED consistent with old libI77 +lread.c + use atof() + allow "nnn*," when reading complex constants +open.c + try opening for writing when open for read fails, with + special uwrt value (2) delaying creat() to first write; + set curunit so error messages don't drop core; + no file name ==> fort.nnn except for STATUS='SCRATCH' +rdfmt.c + use atof(); trust EOF == end-of-file (so don't read past + end-of-file after endfile stmt) +sfe.c + flush stderr, stdout at end of each stmt +wrtfmt.c: + use upper case + put wrt_E and wrt_F into wref.c, use sprintf() + rather than ecvt() and fcvt() [more accurate on VAX] +*/ + +/* 16 Oct. 1988: uwrt = 3 after write, rewind, so close won't zap the file. */ + +/* 10 July 1989: change _bufend to buf_end in fio.h, wsfe.c, wrtfmt.c */ + +/* 28 Nov. 1989: corrections for IEEE and Cray arithmetic */ +/* 29 Nov. 1989: change various int return types to long for f2c */ +/* 30 Nov. 1989: various types from f2c.h */ +/* 6 Dec. 1989: types corrected various places */ +/* 19 Dec. 1989: make iostat= work right for internal I/O */ +/* 8 Jan. 1990: add rsne, wsne -- routines for handling NAMELIST */ +/* 28 Jan. 1990: have NAMELIST read treat $ as &, general white + space as blank */ +/* 27 Mar. 1990: change an = to == in rd_L(rdfmt.c) so formatted reads + of logical values reject letters other than fFtT; + have nowwriting reset cf */ +/* 14 Aug. 1990: adjust lread.c to treat tabs as spaces in list input */ +/* 17 Aug. 1990: adjust open.c to recognize blank='Z...' as well as + blank='z...' when reopening an open file */ +/* 30 Aug. 1990: prevent embedded blanks in list output of complex values; + omit exponent field in list output of values of + magnitude between 10 and 1e8; prevent writing stdin + and reading stdout or stderr; don't close stdin, stdout, + or stderr when reopening units 5, 6, 0. */ +/* 18 Sep. 1990: add component udev to unit and consider old == new file + iff uinode and udev values agree; use stat rather than + access to check existence of file (when STATUS='OLD')*/ +/* 2 Oct. 1990: adjust rewind.c so two successive rewinds after a write + don't clobber the file. */ +/* 9 Oct. 1990: add #include "fcntl.h" to endfile.c, err.c, open.c; + adjust g_char in util.c for segmented memories. */ +/* 17 Oct. 1990: replace abort() and _cleanup() with calls on + sig_die(...,1) (defined in main.c). */ +/* 5 Nov. 1990: changes to open.c: complain if new= is specified and the + file already exists; allow file= to be omitted in open stmts + and allow status='replace' (Fortran 90 extensions). */ +/* 11 Dec. 1990: adjustments for POSIX. */ +/* 15 Jan. 1991: tweak i_ungetc in rsli.c to allow reading from + strings in read-only memory. */ +/* 25 Apr. 1991: adjust namelist stuff to work with f2c -i2 */ +/* 26 Apr. 1991: fix some bugs with NAMELIST read of multi-dim. arrays */ +/* 16 May 1991: increase LEFBL in lio.h to bypass NeXT bug */ +/* 17 Oct. 1991: change type of length field in sequential unformatted + records from int to long (for systems where sizeof(int) + can vary, depending on the compiler or compiler options). */ +/* 14 Nov. 1991: change uint to Uint in fmt.h, rdfmt.c, wrtfmt.c. */ +/* 25 Nov. 1991: change uint to Uint in lwrite.c; change sizeof(int) to + sizeof(uioint) in fseeks in sue.c (missed on 17 Oct.). */ +/* 1 Dec. 1991: uio.c: add test for read failure (seq. unformatted reads); + adjust an error return from EOF to off end of record */ +/* 12 Dec. 1991: rsli.c: fix bug with internal list input that caused + the last character of each record to be ignored. + iio.c: adjust error message in internal formatted + input from "end-of-file" to "off end of record" if + the format specifies more characters than the + record contains. */ +/* 17 Jan. 1992: lread.c, rsne.c: in list and namelist input, + treat "r* ," and "r*," alike (where r is a + positive integer constant), and fix a bug in + handling null values following items with repeat + counts (e.g., 2*1,,3); for namelist reading + of a numeric array, allow a new name-value subsequence + to terminate the current one (as though the current + one ended with the right number of null values). + lio.h, lwrite.c: omit insignificant zeros in + list and namelist output. To get the old + behavior, compile with -DOld_list_output . */ +/* 18 Jan. 1992: make list output consistent with F format by + printing .1 rather than 0.1 (introduced yesterday). */ +/* 3 Feb. 1992: rsne.c: fix namelist read bug that caused the + character following a comma to be ignored. */ +/* 19 May 1992: adjust iio.c, ilnw.c, rdfmt.c and rsli.c to make err= + work with internal list and formatted I/O. */ +/* 18 July 1992: adjust rsne.c to allow namelist input to stop at + an & (e.g. &end). */ +/* 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined ; + recognize Z format (assuming 8-bit bytes). */ +/* 14 Aug. 1992: tweak wrt_E in wref.c to avoid -NaN */ +/* 23 Oct. 1992: Supply missing l_eof = 0 assignment to s_rsne() in rsne.c + (so end-of-file on other files won't confuse namelist + reads of external files). Prepend f__ to external + names that are only of internal interest to lib[FI]77. */ +/* 1 Feb. 1993: backspace.c: fix bug that bit when last char of 2nd + buffer == '\n'. + endfile.c: guard against tiny L_tmpnam; close and reopen + files in t_runc(). + lio.h: lengthen LINTW (buffer size in lwrite.c). + err.c, open.c: more prepending of f__ (to [rw]_mode). */ +/* 5 Feb. 1993: tweaks to NAMELIST: rsne.c: ? prints the namelist being + sought; namelists of the wrong name are skipped (after + an error message; xwsne.c: namelist writes have a + newline before each new variable. + open.c: ACCESS='APPEND' positions sequential files + at EOF (nonstandard extension -- that doesn't require + changing data structures). */ +/* 9 Feb. 1993: Change some #ifdef MSDOS lines to #ifdef NON_UNIX_STDIO. + err.c: under NON_UNIX_STDIO, avoid close(creat(name,0666)) + when the unit has another file descriptor for name. */ +/* 4 March 1993: err.c, open.c: take declaration of fdopen from rawio.h; + open.c: always give f__w_mode[] 4 elements for use + in t_runc (in endfile.c -- for change of 1 Feb. 1993). */ +/* 6 March 1993: uio.c: adjust off-end-of-record test for sequential + unformatted reads to respond to err= rather than end=. */ +/* 12 March 1993: various tweaks for C++ */ +/* 6 April 1993: adjust error returns for formatted inputs to flush + the current input line when err=label is specified. + To restore the old behavior (input left mid-line), + either adjust the #definition of errfl in fio.h or + omit the invocation of f__doend in err__fl (in err.c). */ +/* 23 June 1993: iio.c: fix bug in format reversions for internal writes. */ +/* 5 Aug. 1993: lread.c: fix bug in handling repetition counts for + logical data (during list or namelist input). + Change struct f__syl to struct syl (for buggy compilers). */ +/* 7 Aug. 1993: lread.c: fix bug in namelist reading of incomplete + logical arrays. */ +/* 9 Aug. 1993: lread.c: fix bug in namelist reading of an incomplete + array of numeric data followed by another namelist + item whose name starts with 'd', 'D', 'e', or 'E'. */ +/* 8 Sept. 1993: open.c: protect #include "sys/..." with + #ifndef NON_UNIX_STDIO; Version date not changed. */ +/* 10 Nov. 1993: backspace.c: add nonsense for #ifdef MSDOS */ +/* 8 Dec. 1993: iio.c: adjust internal formatted reads to treat + short records as though padded with blanks + (rather than causing an "off end of record" error). */ +/* 22 Feb. 1994: lread.c: check that realloc did not return NULL. */ +/* 6 June 1994: Under NON_UNIX_STDIO, use binary mode for direct + formatted files (avoiding any confusion regarding \n). */ +/* 5 July 1994: Fix bug (introduced 6 June 1994?) in reopening files + under NON_UNIX_STDIO. */ +/* 6 July 1994: wref.c: protect with #ifdef GOOD_SPRINTF_EXPONENT an + optimization that requires exponents to have 2 digits + when 2 digits suffice. + lwrite.c wsfe.c (list and formatted external output): + omit ' ' carriage-control when compiled with + -DOMIT_BLANK_CC . Off-by-one bug fixed in character + count for list output of character strings. + Omit '.' in list-directed printing of Nan, Infinity. */ +/* 12 July 1994: wrtfmt.c: under G11.4, write 0. as " .0000 " rather + than " .0000E+00". */ +/* 3 Aug. 1994: lwrite.c: do not insert a newline when appending an + oversize item to an empty line. */ +/* 12 Aug. 1994: rsli.c rsne.c: fix glitch (reset nml_read) that kept + ERR= (in list- or format-directed input) from working + after a NAMELIST READ. */ +/* 7 Sept. 1994: typesize.c: adjust to allow types LOGICAL*1, LOGICAL*2, + INTEGER*1, and (under -DAllow_TYQUAD) INTEGER*8 + in NAMELISTs. */ +/* 6 Oct. 1994: util.c: omit f__mvgbt, as it is never used. */ +/* 2 Nov. 1994: add #ifdef ALWAYS_FLUSH logic. */ +/* 26 Jan. 1995: wref.c: fix glitch in printing the exponent of 0 when + GOOD_SPRINTF_EXPONENT is not #defined. */ +/* 24 Feb. 1995: iio.c: z_getc: insert (unsigned char *) to allow + internal reading of characters with high-bit set + (on machines that sign-extend characters). */ +/* 14 March 1995:lread.c and rsfe.c: adjust s_rsle and s_rsfe to + check for end-of-file (to prevent infinite loops + with empty read statements). */ +/* 26 May 1995: iio.c: z_wnew: fix bug in handling T format items + in internal writes whose last item is written to + an earlier position than some previous item. */ +/* 29 Aug. 1995: backspace.c: adjust MSDOS logic. */ +/* 6 Sept. 1995: Adjust namelist input to treat a subscripted name + whose subscripts do not involve colons similarly + to the name without a subscript: accept several + values, stored in successive elements starting at + the indicated subscript. Adjust namelist output + to quote character strings (avoiding confusion with + arrays of character strings). Adjust f_init calls + for people who don't use libF77's main(); now open and + namelist read statements invoke f_init if needed. */ +/* 7 Sept. 1995: Fix some bugs with -DAllow_TYQUAD (for integer*8). + Add -DNo_Namelist_Comments lines to rsne.c. */ +/* 5 Oct. 1995: wrtfmt.c: fix bug with t editing (f__cursor was not + always zeroed in mv_cur). */ +/* 11 Oct. 1995: move defs of f__hiwater, f__svic, f__icptr from wrtfmt.c + to err.c */ +/* 15 Mar. 1996: lread.c, rsfe.c: honor END= in READ stmt with empty iolist */ + +/* 13 May 1996: add ftell_.c and fseek_.c */ +/* 9 June 1996: Adjust rsli.c and lread.c so internal list input with + too few items in the input string will honor end= . */ +/* 12 Sept. 1995:fmtlib.c: fix glitch in printing the most negative integer. */ +/* 25 Sept. 1995:fmt.h: for formatted writes of negative integer*1 values, + make ic signed on ANSI systems. If formatted writes of + integer*1 values trouble you when using a K&R C compiler, + switch to an ANSI compiler or use a compiler flag that + makes characters signed. */ +/* 9 Dec. 1996: d[fu]e.c, err.c: complain about non-positive rec= + in direct read and write statements. + ftell_.c: change param "unit" to "Unit" for -DKR_headers. */ +/* 26 Feb. 1997: ftell_.c: on systems that define SEEK_SET, etc., use + SEEK_SET, SEEK_CUR, SEEK_END for *whence = 0, 1, 2. */ +/* 7 Apr. 1997: fmt.c: adjust to complain at missing numbers in formats + (but still treat missing ".nnn" as ".0"). */ +/* 11 Apr. 1997: err.c: attempt to make stderr line buffered rather + than fully buffered. (Buffering is needed for format + items T and TR.) */ +/* 27 May 1997: ftell_.c: fix typo (that caused the third argument to be + treated as 2 on some systems). */ +/* 5 Aug. 1997: lread.c: adjust to accord with a change to the Fortran 8X + draft (in 1990 or 1991) that rescinded permission to elide + quote marks in namelist input of character data; compile + with -DF8X_NML_ELIDE_QUOTES to get the old behavior. + wrtfmt.o: wrt_G: tweak to print the right number of 0's + for zero under G format. */ +/* 17 June 1997: detect recursive I/O and call f__fatal explaining it. */ + +#include + +void +g77__ivers__ () +{ + fprintf (stderr, "__G77_LIBI77_VERSION__: %s", __G77_LIBI77_VERSION__); + fputs (junk, stderr); +} diff --git a/gcc/f/runtime/libI77/backspace.c b/gcc/f/runtime/libI77/backspace.c new file mode 100644 index 000000000000..8413d5f68210 --- /dev/null +++ b/gcc/f/runtime/libI77/backspace.c @@ -0,0 +1,101 @@ +#include +#include "f2c.h" +#include "fio.h" +#ifdef KR_headers +integer f_back(a) alist *a; +#else +integer f_back(alist *a) +#endif +{ unit *b; + int i, n, ndec; +#if defined (MSDOS) && !defined (GO32) + int j, k; + long w, z; +#endif + long x, y; + char buf[32]; + if (f__init & 2) + f__fatal (131, "I/O recursion"); + if(a->aunit >= MXUNIT || a->aunit < 0) + err(a->aerr,101,"backspace"); + b= &f__units[a->aunit]; + if(b->useek==0) err(a->aerr,106,"backspace"); + if(b->ufd==NULL) { + fk_open(1, 1, a->aunit); + return(0); + } + if(b->uend==1) + { b->uend=0; + return(0); + } + if(b->uwrt) { + (void) t_runc(a); + if (f__nowreading(b)) + err(a->aerr,errno,"backspace"); + } + if(b->url>0) + { + x=ftell(b->ufd); + y = x % b->url; + if(y == 0) x--; + x /= b->url; + x *= b->url; + (void) fseek(b->ufd,x,SEEK_SET); + return(0); + } + + if(b->ufmt==0) + { (void) fseek(b->ufd,-(long)sizeof(int),SEEK_CUR); + (void) fread((char *)&n,sizeof(int),1,b->ufd); + (void) fseek(b->ufd,-(long)n-2*sizeof(int),SEEK_CUR); + return(0); + } +#if defined (MSDOS) && !defined (GO32) + w = -1; +#endif + for(ndec = 1;; ndec = 0) + { + y = x = ftell(b->ufd); + if(x < sizeof(buf)) + x = 0; + else + x -= sizeof(buf); + (void) fseek(b->ufd,x,SEEK_SET); + n=fread(buf,1,(size_t)(y-x), b->ufd); + for(i = n - ndec; --i >= 0; ) + { + if(buf[i]!='\n') continue; +#if defined (MSDOS) && !defined (GO32) + for(j = k = 0; j <= i; j++) + if (buf[j] == '\n') + k++; + fseek(b->ufd,x,SEEK_SET); + for(;;) + if (getc(b->ufd) == '\n') { + if ((z = ftell(b->ufd)) >= y && ndec) { + if (w == -1) + goto break2; + break; + } + if (--k <= 0) + return 0; + w = z; + } + fseek(b->ufd, w, SEEK_SET); +#else + fseek(b->ufd,(long)(i+1-n),SEEK_CUR); +#endif + return(0); + } +#if defined (MSDOS) && !defined (GO32) + break2: +#endif + if(x==0) + { + (void) fseek(b->ufd, 0L, SEEK_SET); + return(0); + } + else if(n<=0) err(a->aerr,(EOF),"backspace"); + (void) fseek(b->ufd, x, SEEK_SET); + } +} diff --git a/gcc/f/runtime/libI77/close.c b/gcc/f/runtime/libI77/close.c new file mode 100644 index 000000000000..40e15c175f4d --- /dev/null +++ b/gcc/f/runtime/libI77/close.c @@ -0,0 +1,99 @@ +#include "f2c.h" +#include "fio.h" +#ifdef KR_headers +integer f_clos(a) cllist *a; +#else +#undef abs +#undef min +#undef max +#include +#ifdef NON_UNIX_STDIO +#ifndef unlink +#define unlink remove +#endif +#else +#if defined (MSDOS) && !defined (GO32) +#include "io.h" +#else +#ifdef __cplusplus +extern "C" int unlink(const char*); +#else +extern int unlink(const char*); +#endif +#endif +#endif + +integer f_clos(cllist *a) +#endif +{ unit *b; + + if (f__init & 2) + f__fatal (131, "I/O recursion"); + if(a->cunit >= MXUNIT) return(0); + b= &f__units[a->cunit]; + if(b->ufd==NULL) + goto done; + if (!a->csta) + if (b->uscrtch == 1) + goto Delete; + else + goto Keep; + switch(*a->csta) { + default: + Keep: + case 'k': + case 'K': + if(b->uwrt == 1) + t_runc((alist *)a); + if(b->ufnm) { + fclose(b->ufd); + free(b->ufnm); + } + break; + case 'd': + case 'D': + Delete: + if(b->ufnm) { + fclose(b->ufd); + unlink(b->ufnm); /*SYSDEP*/ + free(b->ufnm); + } + } + b->ufd=NULL; + done: + b->uend=0; + b->ufnm=NULL; + return(0); + } + void +#ifdef KR_headers +f_exit() +#else +f_exit(void) +#endif +{ int i; + static cllist xx; + if (f__init & 1) + return; /* Not initialized, so no open units. */ + if (!xx.cerr) { + xx.cerr=1; + xx.csta=NULL; + for(i=0;iuend || f__curunit->url <= f__recpos + || f__curunit->url == 1) return 0; + do { + getc(f__cf); + } while(++f__recpos < f__curunit->url); + return 0; +} +y_getc(Void) +{ + int ch; + if(f__curunit->uend) return(-1); + if((ch=getc(f__cf))!=EOF) + { + f__recpos++; + if(f__curunit->url>=f__recpos || + f__curunit->url==1) + return(ch); + else return(' '); + } + if(feof(f__cf)) + { + f__curunit->uend=1; + errno=0; + return(-1); + } + err(f__elist->cierr,errno,"readingd"); +} +#ifdef KR_headers +y_putc(c) +#else +y_putc(int c) +#endif +{ + f__recpos++; + if(f__recpos <= f__curunit->url || f__curunit->url==1) + putc(c,f__cf); + else + err(f__elist->cierr,110,"dout"); + return(0); +} +y_rev(Void) +{ /*what about work done?*/ + if(f__curunit->url==1 || f__recpos==f__curunit->url) + return(0); + while(f__recposurl) + (*f__putn)(' '); + f__recpos=0; + return(0); +} +y_err(Void) +{ + err(f__elist->cierr, 110, "dfe"); +} + +y_newrec(Void) +{ + if(f__curunit->url == 1 || f__recpos == f__curunit->url) { + f__hiwater = f__recpos = f__cursor = 0; + return(1); + } + if(f__hiwater > f__recpos) + f__recpos = f__hiwater; + y_rev(); + f__hiwater = f__cursor = 0; + return(1); +} + +#ifdef KR_headers +c_dfe(a) cilist *a; +#else +c_dfe(cilist *a) +#endif +{ + f__sequential=0; + f__formatted=f__external=1; + f__elist=a; + f__cursor=f__scale=f__recpos=0; + if(a->ciunit>MXUNIT || a->ciunit<0) + err(a->cierr,101,"startchk"); + f__curunit = &f__units[a->ciunit]; + if(f__curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit)) + err(a->cierr,104,"dfe"); + f__cf=f__curunit->ufd; + if(!f__curunit->ufmt) err(a->cierr,102,"dfe"); + if(!f__curunit->useek) err(a->cierr,104,"dfe"); + f__fmtbuf=a->cifmt; + if(a->cirec <= 0) + err(a->cierr,130,"dfe"); + (void) fseek(f__cf,(long)f__curunit->url * (a->cirec-1),SEEK_SET); + f__curunit->uend = 0; + return(0); +} +#ifdef KR_headers +integer s_rdfe(a) cilist *a; +#else +integer s_rdfe(cilist *a) +#endif +{ + int n; + if(f__init != 1) f_init(); + f__init = 3; + f__reading=1; + if(n=c_dfe(a))return(n); + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,"read start"); + f__getn = y_getc; + f__doed = rd_ed; + f__doned = rd_ned; + f__dorevert = f__donewrec = y_err; + f__doend = y_rsk; + if(pars_f(f__fmtbuf)<0) + err(a->cierr,100,"read start"); + fmt_bg(); + return(0); +} +#ifdef KR_headers +integer s_wdfe(a) cilist *a; +#else +integer s_wdfe(cilist *a) +#endif +{ + int n; + if(f__init != 1) f_init(); + f__init = 3; + f__reading=0; + if(n=c_dfe(a)) return(n); + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr,errno,"startwrt"); + f__putn = y_putc; + f__doed = w_ed; + f__doned= w_ned; + f__dorevert = y_err; + f__donewrec = y_newrec; + f__doend = y_rev; + if(pars_f(f__fmtbuf)<0) + err(a->cierr,100,"startwrt"); + fmt_bg(); + return(0); +} +integer e_rdfe(Void) +{ + f__init = 1; + (void) en_fio(); + return(0); +} +integer e_wdfe(Void) +{ + f__init = 1; + return en_fio(); +} diff --git a/gcc/f/runtime/libI77/dolio.c b/gcc/f/runtime/libI77/dolio.c new file mode 100644 index 000000000000..4b5a2ca6588c --- /dev/null +++ b/gcc/f/runtime/libI77/dolio.c @@ -0,0 +1,20 @@ +#include "f2c.h" + +#ifdef __cplusplus +extern "C" { +#endif +#ifdef KR_headers +extern int (*f__lioproc)(); + +integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len; +#else +extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint); + +integer do_lio(ftnint *type, ftnint *number, char *ptr, ftnlen len) +#endif +{ + return((*f__lioproc)(number,ptr,len,*type)); +} +#ifdef __cplusplus + } +#endif diff --git a/gcc/f/runtime/libI77/due.c b/gcc/f/runtime/libI77/due.c new file mode 100644 index 000000000000..dec58657b506 --- /dev/null +++ b/gcc/f/runtime/libI77/due.c @@ -0,0 +1,73 @@ +#include "f2c.h" +#include "fio.h" + +#ifdef KR_headers +c_due(a) cilist *a; +#else +c_due(cilist *a) +#endif +{ + if(f__init != 1) f_init(); + f__init = 3; + if(a->ciunit>=MXUNIT || a->ciunit<0) + err(a->cierr,101,"startio"); + f__sequential=f__formatted=f__recpos=0; + f__external=1; + f__curunit = &f__units[a->ciunit]; + f__elist=a; + if(f__curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due"); + f__cf=f__curunit->ufd; + if(f__curunit->ufmt) err(a->cierr,102,"cdue"); + if(!f__curunit->useek) err(a->cierr,104,"cdue"); + if(f__curunit->ufd==NULL) err(a->cierr,114,"cdue"); + if(a->cirec <= 0) + err(a->cierr,130,"due"); + (void) fseek(f__cf,(long)(a->cirec-1)*f__curunit->url,SEEK_SET); + f__curunit->uend = 0; + return(0); +} +#ifdef KR_headers +integer s_rdue(a) cilist *a; +#else +integer s_rdue(cilist *a) +#endif +{ + int n; + f__reading=1; + if(n=c_due(a)) return(n); + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,"read start"); + return(0); +} +#ifdef KR_headers +integer s_wdue(a) cilist *a; +#else +integer s_wdue(cilist *a) +#endif +{ + int n; + f__reading=0; + if(n=c_due(a)) return(n); + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr,errno,"write start"); + return(0); +} +integer e_rdue(Void) +{ + f__init = 1; + if(f__curunit->url==1 || f__recpos==f__curunit->url) + return(0); + (void) fseek(f__cf,(long)(f__curunit->url-f__recpos),SEEK_CUR); + if(ftell(f__cf)%f__curunit->url) + err(f__elist->cierr,200,"syserr"); + return(0); +} +integer e_wdue(Void) +{ + f__init = 1; +#ifdef ALWAYS_FLUSH + if (fflush(f__cf)) + err(f__elist->cierr,errno,"write end"); +#endif + return(e_rdue()); +} diff --git a/gcc/f/runtime/libI77/endfile.c b/gcc/f/runtime/libI77/endfile.c new file mode 100644 index 000000000000..6050d1e3b303 --- /dev/null +++ b/gcc/f/runtime/libI77/endfile.c @@ -0,0 +1,195 @@ +#include "f2c.h" +#include "fio.h" +#include +#include "rawio.h" + +#ifdef KR_headers +extern char *strcpy(); +#else +#undef abs +#undef min +#undef max +#include +#include +#endif + +#ifdef NON_UNIX_STDIO +#ifndef unlink +#define unlink remove +#endif +#else +#if defined (MSDOS) && !defined (GO32) +#include "io.h" +#endif +#endif + +#ifdef NON_UNIX_STDIO +extern char *f__r_mode[], *f__w_mode[]; +#endif + +#ifdef KR_headers +integer f_end(a) alist *a; +#else +integer f_end(alist *a) +#endif +{ + unit *b; + if (f__init & 2) + f__fatal (131, "I/O recursion"); + if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile"); + b = &f__units[a->aunit]; + if(b->ufd==NULL) { + char nbuf[10]; + (void) sprintf(nbuf,"fort.%ld",a->aunit); +#ifdef NON_UNIX_STDIO + { FILE *tf; + if (tf = fopen(nbuf, f__w_mode[0])) + fclose(tf); + } +#else + close(creat(nbuf, 0666)); +#endif + return(0); + } + b->uend=1; + return(b->useek ? t_runc(a) : 0); +} + + static int +#ifdef NON_UNIX_STDIO +#ifdef KR_headers +copy(from, len, to) char *from, *to; register long len; +#else +copy(FILE *from, register long len, FILE *to) +#endif +{ + int k, len1; + char buf[BUFSIZ]; + + while(fread(buf, len1 = len > BUFSIZ ? BUFSIZ : (int)len, 1, from)) { + if (!fwrite(buf, len1, 1, to)) + return 1; + if ((len -= len1) <= 0) + break; + } + return 0; + } +#else +#ifdef KR_headers +copy(from, len, to) char *from, *to; register long len; +#else +copy(char *from, register long len, char *to) +#endif +{ + register size_t n; + int k, rc = 0, tmp; + char buf[BUFSIZ]; + + if ((k = open(from, O_RDONLY)) < 0) + return 1; + if ((tmp = creat(to,0666)) < 0) + return 1; + while((n = read(k, buf, (size_t) (len > BUFSIZ ? BUFSIZ : (int)len))) > 0) { + if (write(tmp, buf, n) != n) + { rc = 1; break; } + if ((len -= n) <= 0) + break; + } + close(k); + close(tmp); + return n < 0 ? 1 : rc; + } +#endif + +#ifndef L_tmpnam +#define L_tmpnam 16 +#endif + + int +#ifdef KR_headers +t_runc(a) alist *a; +#else +t_runc(alist *a) +#endif +{ + char nm[L_tmpnam+12]; /* extra space in case L_tmpnam is tiny */ + long loc, len; + unit *b; +#ifdef NON_UNIX_STDIO + FILE *bf, *tf; +#else + FILE *bf; +#endif + int rc = 0; + + b = &f__units[a->aunit]; + if(b->url) + return(0); /*don't truncate direct files*/ + loc=ftell(bf = b->ufd); + fseek(bf,0L,SEEK_END); + len=ftell(bf); + if (loc >= len || b->useek == 0 || b->ufnm == NULL) + return(0); +#ifdef NON_UNIX_STDIO + fclose(b->ufd); +#else + rewind(b->ufd); /* empty buffer */ +#endif + if (!loc) { +#ifdef NON_UNIX_STDIO + if (!(bf = fopen(b->ufnm, f__w_mode[b->ufmt]))) +#else + if (close(creat(b->ufnm,0666))) +#endif + rc = 1; + if (b->uwrt) + b->uwrt = 1; + goto done; + } +#ifdef _POSIX_SOURCE + tmpnam(nm); +#else + strcpy(nm,"tmp.FXXXXXX"); + mktemp(nm); +#endif +#ifdef NON_UNIX_STDIO + if (!(bf = fopen(b->ufnm, f__r_mode[0]))) { + bad: + rc = 1; + goto done; + } + if (!(tf = fopen(nm, f__w_mode[0]))) + goto bad; + if (copy(bf, loc, tf)) { + bad1: + rc = 1; + goto done1; + } + if (!(bf = freopen(b->ufnm, f__w_mode[0], bf))) + goto bad1; + if (!(tf = freopen(nm, f__r_mode[0], tf))) + goto bad1; + if (copy(tf, loc, bf)) + goto bad1; + if (f__w_mode[0] != f__w_mode[b->ufmt]) { + if (!(bf = freopen(b->ufnm, f__w_mode[b->ufmt|2], bf))) + goto bad1; + fseek(bf, loc, SEEK_SET); + } +done1: + fclose(tf); + unlink(nm); +done: + f__cf = b->ufd = bf; +#else + if (copy(b->ufnm, loc, nm) + || copy(nm, loc, b->ufnm)) + rc = 1; + unlink(nm); + fseek(b->ufd, loc, SEEK_SET); +done: +#endif + if (rc) + err(a->aerr,111,"endfile"); + return 0; + } diff --git a/gcc/f/runtime/libI77/err.c b/gcc/f/runtime/libI77/err.c new file mode 100644 index 000000000000..1d0188737be4 --- /dev/null +++ b/gcc/f/runtime/libI77/err.c @@ -0,0 +1,298 @@ +#ifndef NON_UNIX_STDIO +#include +#include +#endif +#include "f2c.h" +#if defined (NON_UNIX_STDIO) || defined (MISSING_FILE_ELEMS) +#ifdef KR_headers +extern char *malloc(); +#else +#undef abs +#undef min +#undef max +#include +#endif +#endif +#include "fio.h" +#include "fmt.h" /* for struct syl */ +#include "rawio.h" /* for fcntl.h, fdopen */ + +/*global definitions*/ +unit f__units[MXUNIT]; /*unit table*/ +int f__init; /*bit 0: set after initializations; + bit 1: set during I/O involving returns to + caller of library (or calls to user code)*/ +cilist *f__elist; /*active external io list*/ +icilist *f__svic; /*active internal io list*/ +flag f__reading; /*1 if reading, 0 if writing*/ +flag f__cplus,f__cblank; +char *f__fmtbuf; +flag f__external; /*1 if external io, 0 if internal */ +#ifdef KR_headers +int (*f__doed)(),(*f__doned)(); +int (*f__doend)(),(*f__donewrec)(),(*f__dorevert)(); +int (*f__getn)(),(*f__putn)(); /*for formatted io*/ +#else +int (*f__getn)(void),(*f__putn)(int); /*for formatted io*/ +int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*); +int (*f__dorevert)(void),(*f__donewrec)(void),(*f__doend)(void); +#endif +flag f__sequential; /*1 if sequential io, 0 if direct*/ +flag f__formatted; /*1 if formatted io, 0 if unformatted*/ +FILE *f__cf; /*current file*/ +unit *f__curunit; /*current unit*/ +int f__recpos; /*place in current record*/ +int f__cursor, f__hiwater, f__scale; +char *f__icptr; + +/*error messages*/ +char *F_err[] = +{ + "error in format", /* 100 */ + "illegal unit number", /* 101 */ + "formatted io not allowed", /* 102 */ + "unformatted io not allowed", /* 103 */ + "direct io not allowed", /* 104 */ + "sequential io not allowed", /* 105 */ + "can't backspace file", /* 106 */ + "null file name", /* 107 */ + "can't stat file", /* 108 */ + "unit not connected", /* 109 */ + "off end of record", /* 110 */ + "truncation failed in endfile", /* 111 */ + "incomprehensible list input", /* 112 */ + "out of free space", /* 113 */ + "unit not connected", /* 114 */ + "read unexpected character", /* 115 */ + "bad logical input field", /* 116 */ + "bad variable type", /* 117 */ + "bad namelist name", /* 118 */ + "variable not in namelist", /* 119 */ + "no end record", /* 120 */ + "variable count incorrect", /* 121 */ + "subscript for scalar variable", /* 122 */ + "invalid array section", /* 123 */ + "substring out of bounds", /* 124 */ + "subscript out of bounds", /* 125 */ + "can't read file", /* 126 */ + "can't write file", /* 127 */ + "'new' file exists", /* 128 */ + "can't append to file", /* 129 */ + "non-positive record number", /* 130 */ + "I/O started while already doing I/O" /* 131 */ +}; +#define MAXERR (sizeof(F_err)/sizeof(char *)+100) + +#ifdef KR_headers +f__canseek(f) FILE *f; /*SYSDEP*/ +#else +f__canseek(FILE *f) /*SYSDEP*/ +#endif +{ +#ifdef NON_UNIX_STDIO + return !isatty(fileno(f)); +#else + struct stat x; + + if (fstat(fileno(f),&x) < 0) + return(0); +#ifdef S_IFMT + switch(x.st_mode & S_IFMT) { + case S_IFDIR: + case S_IFREG: + if(x.st_nlink > 0) /* !pipe */ + return(1); + else + return(0); + case S_IFCHR: + if(isatty(fileno(f))) + return(0); + return(1); +#ifdef S_IFBLK + case S_IFBLK: + return(1); +#endif + } +#else +#ifdef S_ISDIR + /* POSIX version */ + if (S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) { + if(x.st_nlink > 0) /* !pipe */ + return(1); + else + return(0); + } + if (S_ISCHR(x.st_mode)) { + if(isatty(fileno(f))) + return(0); + return(1); + } + if (S_ISBLK(x.st_mode)) + return(1); +#else + Help! How does fstat work on this system? +#endif +#endif + return(0); /* who knows what it is? */ +#endif +} + + void +#ifdef KR_headers +f__fatal(n,s) char *s; +#else +f__fatal(int n, char *s) +#endif +{ + static int dead = 0; + + if(n<100 && n>=0) perror(s); /*SYSDEP*/ + else if(n >= (int)MAXERR || n < -1) + { fprintf(stderr,"%s: illegal error number %d\n",s,n); + } + else if(n == -1) fprintf(stderr,"%s: end of file\n",s); + else + fprintf(stderr,"%s: %s\n",s,F_err[n-100]); + if (dead) { + fprintf (stderr, "(libf2c f__fatal already called, aborting.)"); + abort(); + } + dead = 1; + if (f__init & 1) { + if (f__curunit) { + fprintf(stderr,"apparent state: unit %d ",f__curunit-f__units); + fprintf(stderr, f__curunit->ufnm ? "named %s\n" : "(unnamed)\n", + f__curunit->ufnm); + } + else + fprintf(stderr,"apparent state: internal I/O\n"); + if (f__fmtbuf) + fprintf(stderr,"last format: %s\n",f__fmtbuf); + fprintf(stderr,"lately %s %s %s %s",f__reading?"reading":"writing", + f__sequential?"sequential":"direct",f__formatted?"formatted":"unformatted", + f__external?"external":"internal"); + } + f__init &= ~2; /* No longer doing I/O (no more user code to be called). */ + sig_die(" IO", 1); +} +/*initialization routine*/ + VOID +f_init(Void) +{ unit *p; + + if (f__init & 2) + f__fatal (131, "I/O recursion"); + f__init = 1; + p= &f__units[0]; + p->ufd=stderr; + p->useek=f__canseek(stderr); +#ifdef _IOLBF + setvbuf(stderr, (char*)malloc(BUFSIZ+8), _IOLBF, BUFSIZ+8); +#else +#if defined (NON_UNIX_STDIO) || defined (MISSING_FILE_ELEMS) + setbuf(stderr, (char *)malloc(BUFSIZ+8)); +#else + stderr->_flag &= ~_IONBF; +#endif +#endif + p->ufmt=1; + p->uwrt=1; + p = &f__units[5]; + p->ufd=stdin; + p->useek=f__canseek(stdin); + p->ufmt=1; + p->uwrt=0; + p= &f__units[6]; + p->ufd=stdout; + p->useek=f__canseek(stdout); + p->ufmt=1; + p->uwrt=1; +} +#ifdef KR_headers +f__nowreading(x) unit *x; +#else +f__nowreading(unit *x) +#endif +{ + long loc; + int ufmt; + extern char *f__r_mode[]; + + if (!x->ufnm) + goto cantread; + ufmt = x->ufmt; + loc=ftell(x->ufd); + if(freopen(x->ufnm,f__r_mode[ufmt],x->ufd) == NULL) { + cantread: + errno = 126; + return(1); + } + x->uwrt=0; + (void) fseek(x->ufd,loc,SEEK_SET); + return(0); +} +#ifdef KR_headers +f__nowwriting(x) unit *x; +#else +f__nowwriting(unit *x) +#endif +{ + long loc; + int ufmt; + extern char *f__w_mode[]; +#ifndef NON_UNIX_STDIO + int k; +#endif + + if (!x->ufnm) + goto cantwrite; + ufmt = x->ufmt; +#ifdef NON_UNIX_STDIO + ufmt |= 2; +#endif + if (x->uwrt == 3) { /* just did write, rewind */ +#ifdef NON_UNIX_STDIO + if (!(f__cf = x->ufd = + freopen(x->ufnm,f__w_mode[ufmt],x->ufd))) +#else + if (close(creat(x->ufnm,0666))) +#endif + goto cantwrite; + } + else { + loc=ftell(x->ufd); +#ifdef NON_UNIX_STDIO + if (!(f__cf = x->ufd = + freopen(x->ufnm, f__w_mode[ufmt], x->ufd))) +#else + if (fclose(x->ufd) < 0 + || (k = x->uwrt == 2 ? creat(x->ufnm,0666) + : open(x->ufnm,O_WRONLY)) < 0 + || (f__cf = x->ufd = fdopen(k,f__w_mode[ufmt])) == NULL) +#endif + { + x->ufd = NULL; + cantwrite: + errno = 127; + return(1); + } + (void) fseek(x->ufd,loc,SEEK_SET); + } + x->uwrt = 1; + return(0); +} + + int +#ifdef KR_headers +err__fl(f, m, s) int f, m; char *s; +#else +err__fl(int f, int m, char *s) +#endif +{ + if (!f) + f__fatal(m, s); + if (f__doend) + (*f__doend)(); + f__init &= ~2; + return errno = m; + } diff --git a/gcc/f/runtime/libI77/f2ch.add b/gcc/f/runtime/libI77/f2ch.add new file mode 100644 index 000000000000..a2acc17a1596 --- /dev/null +++ b/gcc/f/runtime/libI77/f2ch.add @@ -0,0 +1,162 @@ +/* If you are using a C++ compiler, append the following to f2c.h + for compiling libF77 and libI77. */ + +#ifdef __cplusplus +extern "C" { +extern int abort_(void); +extern double c_abs(complex *); +extern void c_cos(complex *, complex *); +extern void c_div(complex *, complex *, complex *); +extern void c_exp(complex *, complex *); +extern void c_log(complex *, complex *); +extern void c_sin(complex *, complex *); +extern void c_sqrt(complex *, complex *); +extern double d_abs(double *); +extern double d_acos(double *); +extern double d_asin(double *); +extern double d_atan(double *); +extern double d_atn2(double *, double *); +extern void d_cnjg(doublecomplex *, doublecomplex *); +extern double d_cos(double *); +extern double d_cosh(double *); +extern double d_dim(double *, double *); +extern double d_exp(double *); +extern double d_imag(doublecomplex *); +extern double d_int(double *); +extern double d_lg10(double *); +extern double d_log(double *); +extern double d_mod(double *, double *); +extern double d_nint(double *); +extern double d_prod(float *, float *); +extern double d_sign(double *, double *); +extern double d_sin(double *); +extern double d_sinh(double *); +extern double d_sqrt(double *); +extern double d_tan(double *); +extern double d_tanh(double *); +extern double derf_(double *); +extern double derfc_(double *); +extern integer do_fio(ftnint *, char *, ftnlen); +extern integer do_lio(ftnint *, ftnint *, char *, ftnlen); +extern integer do_uio(ftnint *, char *, ftnlen); +extern integer e_rdfe(void); +extern integer e_rdue(void); +extern integer e_rsfe(void); +extern integer e_rsfi(void); +extern integer e_rsle(void); +extern integer e_rsli(void); +extern integer e_rsue(void); +extern integer e_wdfe(void); +extern integer e_wdue(void); +extern integer e_wsfe(void); +extern integer e_wsfi(void); +extern integer e_wsle(void); +extern integer e_wsli(void); +extern integer e_wsue(void); +extern int ef1asc_(ftnint *, ftnlen *, ftnint *, ftnlen *); +extern integer ef1cmc_(ftnint *, ftnlen *, ftnint *, ftnlen *); +extern double erf(double); +extern double erf_(float *); +extern double erfc(double); +extern double erfc_(float *); +extern integer f_back(alist *); +extern integer f_clos(cllist *); +extern integer f_end(alist *); +extern void f_exit(void); +extern integer f_inqu(inlist *); +extern integer f_open(olist *); +extern integer f_rew(alist *); +extern int flush_(void); +extern void getarg_(integer *, char *, ftnlen); +extern void getenv_(char *, char *, ftnlen, ftnlen); +extern short h_abs(short *); +extern short h_dim(short *, short *); +extern short h_dnnt(double *); +extern short h_indx(char *, char *, ftnlen, ftnlen); +extern short h_len(char *, ftnlen); +extern short h_mod(short *, short *); +extern short h_nint(float *); +extern short h_sign(short *, short *); +extern short hl_ge(char *, char *, ftnlen, ftnlen); +extern short hl_gt(char *, char *, ftnlen, ftnlen); +extern short hl_le(char *, char *, ftnlen, ftnlen); +extern short hl_lt(char *, char *, ftnlen, ftnlen); +extern integer i_abs(integer *); +extern integer i_dim(integer *, integer *); +extern integer i_dnnt(double *); +extern integer i_indx(char *, char *, ftnlen, ftnlen); +extern integer i_len(char *, ftnlen); +extern integer i_mod(integer *, integer *); +extern integer i_nint(float *); +extern integer i_sign(integer *, integer *); +extern integer iargc_(void); +extern ftnlen l_ge(char *, char *, ftnlen, ftnlen); +extern ftnlen l_gt(char *, char *, ftnlen, ftnlen); +extern ftnlen l_le(char *, char *, ftnlen, ftnlen); +extern ftnlen l_lt(char *, char *, ftnlen, ftnlen); +extern void pow_ci(complex *, complex *, integer *); +extern double pow_dd(double *, double *); +extern double pow_di(double *, integer *); +extern short pow_hh(short *, shortint *); +extern integer pow_ii(integer *, integer *); +extern double pow_ri(float *, integer *); +extern void pow_zi(doublecomplex *, doublecomplex *, integer *); +extern void pow_zz(doublecomplex *, doublecomplex *, doublecomplex *); +extern double r_abs(float *); +extern double r_acos(float *); +extern double r_asin(float *); +extern double r_atan(float *); +extern double r_atn2(float *, float *); +extern void r_cnjg(complex *, complex *); +extern double r_cos(float *); +extern double r_cosh(float *); +extern double r_dim(float *, float *); +extern double r_exp(float *); +extern double r_imag(complex *); +extern double r_int(float *); +extern double r_lg10(float *); +extern double r_log(float *); +extern double r_mod(float *, float *); +extern double r_nint(float *); +extern double r_sign(float *, float *); +extern double r_sin(float *); +extern double r_sinh(float *); +extern double r_sqrt(float *); +extern double r_tan(float *); +extern double r_tanh(float *); +extern void s_cat(char *, char **, integer *, integer *, ftnlen); +extern integer s_cmp(char *, char *, ftnlen, ftnlen); +extern void s_copy(char *, char *, ftnlen, ftnlen); +extern int s_paus(char *, ftnlen); +extern integer s_rdfe(cilist *); +extern integer s_rdue(cilist *); +extern integer s_rnge(char *, integer, char *, integer); +extern integer s_rsfe(cilist *); +extern integer s_rsfi(icilist *); +extern integer s_rsle(cilist *); +extern integer s_rsli(icilist *); +extern integer s_rsne(cilist *); +extern integer s_rsni(icilist *); +extern integer s_rsue(cilist *); +extern int s_stop(char *, ftnlen); +extern integer s_wdfe(cilist *); +extern integer s_wdue(cilist *); +extern integer s_wsfe(cilist *); +extern integer s_wsfi(icilist *); +extern integer s_wsle(cilist *); +extern integer s_wsli(icilist *); +extern integer s_wsne(cilist *); +extern integer s_wsni(icilist *); +extern integer s_wsue(cilist *); +extern void sig_die(char *, int); +extern integer signal_(integer *, void (*)(int)); +extern integer system_(char *, ftnlen); +extern double z_abs(doublecomplex *); +extern void z_cos(doublecomplex *, doublecomplex *); +extern void z_div(doublecomplex *, doublecomplex *, doublecomplex *); +extern void z_exp(doublecomplex *, doublecomplex *); +extern void z_log(doublecomplex *, doublecomplex *); +extern void z_sin(doublecomplex *, doublecomplex *); +extern void z_sqrt(doublecomplex *, doublecomplex *); + } +#endif diff --git a/gcc/f/runtime/libI77/fio.h b/gcc/f/runtime/libI77/fio.h new file mode 100644 index 000000000000..769d360a6263 --- /dev/null +++ b/gcc/f/runtime/libI77/fio.h @@ -0,0 +1,102 @@ +#include +#include +#ifndef NULL +/* ANSI C */ +#include +#endif + +#ifndef SEEK_SET +#define SEEK_SET 0 +#define SEEK_CUR 1 +#define SEEK_END 2 +#endif + +#if defined (MSDOS) && !defined (GO32) +#ifndef NON_UNIX_STDIO +#define NON_UNIX_STDIO +#endif +#endif + +#ifdef UIOLEN_int +typedef int uiolen; +#else +typedef long uiolen; +#endif + +/*units*/ +typedef struct +{ FILE *ufd; /*0=unconnected*/ + char *ufnm; +#if !(defined (MSDOS) && !defined (GO32)) + long uinode; + int udev; +#endif + int url; /*0=sequential*/ + flag useek; /*true=can backspace, use dir, ...*/ + flag ufmt; + flag uprnt; + flag ublnk; + flag uend; + flag uwrt; /*last io was write*/ + flag uscrtch; +} unit; + +extern int f__init; +extern cilist *f__elist; /*active external io list*/ +extern flag f__reading,f__external,f__sequential,f__formatted; +#undef Void +#ifdef KR_headers +#define Void /*void*/ +extern int (*f__getn)(),(*f__putn)(); /*for formatted io*/ +extern long f__inode(); +extern VOID sig_die(); +extern int (*f__donewrec)(), t_putc(), x_wSL(); +extern int c_sfe(), err__fl(), xrd_SL(); +#else +#define Void void +#ifdef __cplusplus +extern "C" { +#endif +extern int (*f__getn)(void),(*f__putn)(int); /*for formatted io*/ +extern long f__inode(char*,int*); +extern void sig_die(char*,int); +extern void f__fatal(int,char*); +extern int t_runc(alist*); +extern int f__nowreading(unit*), f__nowwriting(unit*); +extern int fk_open(int,int,ftnint); +extern int en_fio(void); +extern void f_init(void); +extern int (*f__donewrec)(void), t_putc(int), x_wSL(void); +extern void b_char(char*,char*,ftnlen), g_char(char*,ftnlen,char*); +extern int c_sfe(cilist*), z_rnew(void); +extern int isatty(int); +extern int err__fl(int,int,char*); +extern int xrd_SL(void); +#ifdef __cplusplus + } +#endif +#endif +extern int (*f__doend)(Void); +extern FILE *f__cf; /*current file*/ +extern unit *f__curunit; /*current unit*/ +extern unit f__units[]; +#define err(f,m,s) do {if(f) {f__init &= ~2; errno= m;} else f__fatal(m,s); return(m);} while(0) +#define errfl(f,m,s) do {return err__fl((int)f,m,s);} while(0) + +/*Table sizes*/ +#define MXUNIT 100 + +extern int f__recpos; /*position in current record*/ +extern int f__cursor; /* offset to move to */ +extern int f__hiwater; /* so TL doesn't confuse us */ + +#define WRITE 1 +#define READ 2 +#define SEQ 3 +#define DIR 4 +#define FMT 5 +#define UNF 6 +#define EXT 7 +#define INT 8 + +#define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ) diff --git a/gcc/f/runtime/libI77/fmt.c b/gcc/f/runtime/libI77/fmt.c new file mode 100644 index 000000000000..a82f82153f6d --- /dev/null +++ b/gcc/f/runtime/libI77/fmt.c @@ -0,0 +1,516 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#define skip(s) while(*s==' ') s++ +#ifdef interdata +#define SYLMX 300 +#endif +#ifdef pdp11 +#define SYLMX 300 +#endif +#ifdef vax +#define SYLMX 300 +#endif +#ifndef SYLMX +#define SYLMX 300 +#endif +#define GLITCH '\2' + /* special quote character for stu */ +extern int f__cursor,f__scale; +extern flag f__cblank,f__cplus; /*blanks in I and compulsory plus*/ +struct syl f__syl[SYLMX]; +int f__parenlvl,f__pc,f__revloc; + + static +#ifdef KR_headers +char *ap_end(s) char *s; +#else +char *ap_end(char *s) +#endif +{ char quote; + quote= *s++; + for(;*s;s++) + { if(*s!=quote) continue; + if(*++s!=quote) return(s); + } + if(f__elist->cierr) { + errno = 100; + return(NULL); + } + f__fatal(100, "bad string"); + /*NOTREACHED*/ return 0; +} + static +#ifdef KR_headers +op_gen(a,b,c,d) +#else +op_gen(int a, int b, int c, int d) +#endif +{ struct syl *p= &f__syl[f__pc]; + if(f__pc>=SYLMX) + { fprintf(stderr,"format too complicated:\n"); + sig_die(f__fmtbuf, 1); + } + p->op=a; + p->p1=b; + p->p2=c; + p->p3=d; + return(f__pc++); +} +#ifdef KR_headers +static char *f_list(); +static char *gt_num(s,n,n1) char *s; int *n, n1; +#else +static char *f_list(char*); +static char *gt_num(char *s, int *n, int n1) +#endif +{ int m=0,f__cnt=0; + char c; + for(c= *s;;c = *s) + { if(c==' ') + { s++; + continue; + } + if(c>'9' || c<'0') break; + m=10*m+c-'0'; + f__cnt++; + s++; + } + if(f__cnt==0) { + if (!n1) + s = 0; + *n=n1; + } + else *n=m; + return(s); +} + + static +#ifdef KR_headers +char *f_s(s,curloc) char *s; +#else +char *f_s(char *s, int curloc) +#endif +{ + skip(s); + if(*s++!='(') + { + return(NULL); + } + if(f__parenlvl++ ==1) f__revloc=curloc; + if(op_gen(RET1,curloc,0,0)<0 || + (s=f_list(s))==NULL) + { + return(NULL); + } + skip(s); + return(s); +} + + static +#ifdef KR_headers +ne_d(s,p) char *s,**p; +#else +ne_d(char *s, char **p) +#endif +{ int n,x,sign=0; + struct syl *sp; + switch(*s) + { + default: + return(0); + case ':': (void) op_gen(COLON,0,0,0); break; + case '$': + (void) op_gen(NONL, 0, 0, 0); break; + case 'B': + case 'b': + if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0); + else (void) op_gen(BN,0,0,0); + break; + case 'S': + case 's': + if(*(s+1)=='s' || *(s+1) == 'S') + { x=SS; + s++; + } + else if(*(s+1)=='p' || *(s+1) == 'P') + { x=SP; + s++; + } + else x=S; + (void) op_gen(x,0,0,0); + break; + case '/': (void) op_gen(SLASH,0,0,0); break; + case '-': sign=1; + case '+': s++; /*OUTRAGEOUS CODING TRICK*/ + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + if (!(s=gt_num(s,&n,0))) { + bad: *p = 0; + return 1; + } + switch(*s) + { + default: + return(0); + case 'P': + case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break; + case 'X': + case 'x': (void) op_gen(X,n,0,0); break; + case 'H': + case 'h': + sp = &f__syl[op_gen(H,n,0,0)]; + *(char **)&sp->p2 = s + 1; + s+=n; + break; + } + break; + case GLITCH: + case '"': + case '\'': + sp = &f__syl[op_gen(APOS,0,0,0)]; + *(char **)&sp->p2 = s; + if((*p = ap_end(s)) == NULL) + return(0); + return(1); + case 'T': + case 't': + if(*(s+1)=='l' || *(s+1) == 'L') + { x=TL; + s++; + } + else if(*(s+1)=='r'|| *(s+1) == 'R') + { x=TR; + s++; + } + else x=T; + if (!(s=gt_num(s+1,&n,0))) + goto bad; + s--; + (void) op_gen(x,n,0,0); + break; + case 'X': + case 'x': (void) op_gen(X,1,0,0); break; + case 'P': + case 'p': (void) op_gen(P,1,0,0); break; + } + s++; + *p=s; + return(1); +} + + static +#ifdef KR_headers +e_d(s,p) char *s,**p; +#else +e_d(char *s, char **p) +#endif +{ int i,im,n,w,d,e,found=0,x=0; + char *sv=s; + s=gt_num(s,&n,1); + (void) op_gen(STACK,n,0,0); + switch(*s++) + { + default: break; + case 'E': + case 'e': x=1; + case 'G': + case 'g': + found=1; + if (!(s=gt_num(s,&w,0))) { + bad: + *p = 0; + return 1; + } + if(w==0) break; + if(*s=='.') { + if (!(s=gt_num(s+1,&d,0))) + goto bad; + } + else d=0; + if(*s!='E' && *s != 'e') + (void) op_gen(x==1?E:G,w,d,0); /* default is Ew.dE2 */ + else { + if (!(s=gt_num(s+1,&e,0))) + goto bad; + (void) op_gen(x==1?EE:GE,w,d,e); + } + break; + case 'O': + case 'o': + i = O; + im = OM; + goto finish_I; + case 'Z': + case 'z': + i = Z; + im = ZM; + goto finish_I; + case 'L': + case 'l': + found=1; + if (!(s=gt_num(s,&w,0))) + goto bad; + if(w==0) break; + (void) op_gen(L,w,0,0); + break; + case 'A': + case 'a': + found=1; + skip(s); + if(*s>='0' && *s<='9') + { s=gt_num(s,&w,1); + if(w==0) break; + (void) op_gen(AW,w,0,0); + break; + } + (void) op_gen(A,0,0,0); + break; + case 'F': + case 'f': + if (!(s=gt_num(s,&w,0))) + goto bad; + found=1; + if(w==0) break; + if(*s=='.') { + if (!(s=gt_num(s+1,&d,0))) + goto bad; + } + else d=0; + (void) op_gen(F,w,d,0); + break; + case 'D': + case 'd': + found=1; + if (!(s=gt_num(s,&w,0))) + goto bad; + if(w==0) break; + if(*s=='.') { + if (!(s=gt_num(s+1,&d,0))) + goto bad; + } + else d=0; + (void) op_gen(D,w,d,0); + break; + case 'I': + case 'i': + i = I; + im = IM; + finish_I: + if (!(s=gt_num(s,&w,0))) + goto bad; + found=1; + if(w==0) break; + if(*s!='.') + { (void) op_gen(i,w,0,0); + break; + } + if (!(s=gt_num(s+1,&d,0))) + goto bad; + (void) op_gen(im,w,d,0); + break; + } + if(found==0) + { f__pc--; /*unSTACK*/ + *p=sv; + return(0); + } + *p=s; + return(1); +} + static +#ifdef KR_headers +char *i_tem(s) char *s; +#else +char *i_tem(char *s) +#endif +{ char *t; + int n,curloc; + if(*s==')') return(s); + if(ne_d(s,&t)) return(t); + if(e_d(s,&t)) return(t); + s=gt_num(s,&n,1); + if((curloc=op_gen(STACK,n,0,0))<0) return(NULL); + return(f_s(s,curloc)); +} + + static +#ifdef KR_headers +char *f_list(s) char *s; +#else +char *f_list(char *s) +#endif +{ + for(;*s!=0;) + { skip(s); + if((s=i_tem(s))==NULL) return(NULL); + skip(s); + if(*s==',') s++; + else if(*s==')') + { if(--f__parenlvl==0) + { + (void) op_gen(REVERT,f__revloc,0,0); + return(++s); + } + (void) op_gen(GOTO,0,0,0); + return(++s); + } + } + return(NULL); +} + +#ifdef KR_headers +pars_f(s) char *s; +#else +pars_f(char *s) +#endif +{ + f__parenlvl=f__revloc=f__pc=0; + if(f_s(s,0) == NULL) + { + return(-1); + } + return(0); +} +#define STKSZ 10 +int f__cnt[STKSZ],f__ret[STKSZ],f__cp,f__rp; +flag f__workdone, f__nonl; + + static +#ifdef KR_headers +type_f(n) +#else +type_f(int n) +#endif +{ + switch(n) + { + default: + return(n); + case RET1: + return(RET1); + case REVERT: return(REVERT); + case GOTO: return(GOTO); + case STACK: return(STACK); + case X: + case SLASH: + case APOS: case H: + case T: case TL: case TR: + return(NED); + case F: + case I: + case IM: + case A: case AW: + case O: case OM: + case L: + case E: case EE: case D: + case G: case GE: + case Z: case ZM: + return(ED); + } +} +#ifdef KR_headers +integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr; +#else +integer do_fio(ftnint *number, char *ptr, ftnlen len) +#endif +{ struct syl *p; + int n,i; + for(i=0;i<*number;i++,ptr+=len) + { +loop: switch(type_f((p= &f__syl[f__pc])->op)) + { + default: + fprintf(stderr,"unknown code in do_fio: %d\n%s\n", + p->op,f__fmtbuf); + err(f__elist->cierr,100,"do_fio"); + case NED: + if((*f__doned)(p)) + { f__pc++; + goto loop; + } + f__pc++; + continue; + case ED: + if(f__cnt[f__cp]<=0) + { f__cp--; + f__pc++; + goto loop; + } + if(ptr==NULL) + return((*f__doend)()); + f__cnt[f__cp]--; + f__workdone=1; + if((n=(*f__doed)(p,ptr,len))>0) + errfl(f__elist->cierr,errno,"fmt"); + if(n<0) + err(f__elist->ciend,(EOF),"fmt"); + continue; + case STACK: + f__cnt[++f__cp]=p->p1; + f__pc++; + goto loop; + case RET1: + f__ret[++f__rp]=p->p1; + f__pc++; + goto loop; + case GOTO: + if(--f__cnt[f__cp]<=0) + { f__cp--; + f__rp--; + f__pc++; + goto loop; + } + f__pc=1+f__ret[f__rp--]; + goto loop; + case REVERT: + f__rp=f__cp=0; + f__pc = p->p1; + if(ptr==NULL) + return((*f__doend)()); + if(!f__workdone) return(0); + if((n=(*f__dorevert)()) != 0) return(n); + goto loop; + case COLON: + if(ptr==NULL) + return((*f__doend)()); + f__pc++; + goto loop; + case NONL: + f__nonl = 1; + f__pc++; + goto loop; + case S: + case SS: + f__cplus=0; + f__pc++; + goto loop; + case SP: + f__cplus = 1; + f__pc++; + goto loop; + case P: f__scale=p->p1; + f__pc++; + goto loop; + case BN: + f__cblank=0; + f__pc++; + goto loop; + case BZ: + f__cblank=1; + f__pc++; + goto loop; + } + } + return(0); +} +en_fio(Void) +{ ftnint one=1; + return(do_fio(&one,(char *)NULL,(ftnint)0)); +} + VOID +fmt_bg(Void) +{ + f__workdone=f__cp=f__rp=f__pc=f__cursor=0; + f__cnt[0]=f__ret[0]=0; +} diff --git a/gcc/f/runtime/libI77/fmt.h b/gcc/f/runtime/libI77/fmt.h new file mode 100644 index 000000000000..509746e13b9e --- /dev/null +++ b/gcc/f/runtime/libI77/fmt.h @@ -0,0 +1,99 @@ +struct syl +{ int op,p1,p2,p3; +}; +#define RET1 1 +#define REVERT 2 +#define GOTO 3 +#define X 4 +#define SLASH 5 +#define STACK 6 +#define I 7 +#define ED 8 +#define NED 9 +#define IM 10 +#define APOS 11 +#define H 12 +#define TL 13 +#define TR 14 +#define T 15 +#define COLON 16 +#define S 17 +#define SP 18 +#define SS 19 +#define P 20 +#define BN 21 +#define BZ 22 +#define F 23 +#define E 24 +#define EE 25 +#define D 26 +#define G 27 +#define GE 28 +#define L 29 +#define A 30 +#define AW 31 +#define O 32 +#define NONL 33 +#define OM 34 +#define Z 35 +#define ZM 36 +extern struct syl f__syl[]; +extern int f__pc,f__parenlvl,f__revloc; +typedef union +{ real pf; + doublereal pd; +} ufloat; +typedef union +{ short is; +#ifndef KR_headers + signed +#endif + char ic; + integer il; +#ifdef Allow_TYQUAD + longint ili; +#endif +} Uint; +#ifdef KR_headers +extern int (*f__doed)(),(*f__doned)(); +extern int (*f__dorevert)(); +extern int rd_ed(),rd_ned(); +extern int w_ed(),w_ned(); +#else +#ifdef __cplusplus +extern "C" { +#endif +extern int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*); +extern int (*f__dorevert)(void); +extern void fmt_bg(void); +extern int pars_f(char*); +extern int rd_ed(struct syl*, char*, ftnlen),rd_ned(struct syl*); +extern int w_ed(struct syl*, char*, ftnlen),w_ned(struct syl*); +extern int wrt_E(ufloat*, int, int, int, ftnlen); +extern int wrt_F(ufloat*, int, int, ftnlen); +extern int wrt_L(Uint*, int, ftnlen); +#ifdef __cplusplus + } +#endif +#endif +extern flag f__cblank,f__cplus,f__workdone, f__nonl; +extern char *f__fmtbuf; +extern int f__scale; +#define GET(x) if((x=(*f__getn)())<0) return(x) +#define VAL(x) (x!='\n'?x:' ') +#define PUT(x) (*f__putn)(x) +extern int f__cursor; + +#undef TYQUAD +#ifndef Allow_TYQUAD +#undef longint +#define longint long +#else +#define TYQUAD 14 +#endif + +#ifdef KR_headers +extern char *f__icvt(); +#else +extern char *f__icvt(longint, int*, int*, int); +#endif diff --git a/gcc/f/runtime/libI77/fmtlib.c b/gcc/f/runtime/libI77/fmtlib.c new file mode 100644 index 000000000000..91483fc5290f --- /dev/null +++ b/gcc/f/runtime/libI77/fmtlib.c @@ -0,0 +1,45 @@ +/* @(#)fmtlib.c 1.2 */ +#define MAXINTLENGTH 23 + +#include "f2c.h" +#ifndef Allow_TYQUAD +#undef longint +#define longint long +#undef ulongint +#define ulongint unsigned long +#endif + +#ifdef KR_headers +char *f__icvt(value,ndigit,sign, base) longint value; int *ndigit,*sign; + register int base; +#else +char *f__icvt(longint value, int *ndigit, int *sign, int base) +#endif +{ + static char buf[MAXINTLENGTH+1]; + register int i; + ulongint uvalue; + + if(value > 0) { + uvalue = value; + *sign = 0; + } + else if (value < 0) { + uvalue = -value; + *sign = 1; + } + else { + *sign = 0; + *ndigit = 1; + buf[MAXINTLENGTH-1] = '0'; + return &buf[MAXINTLENGTH-1]; + } + i = MAXINTLENGTH; + do { + buf[--i] = (uvalue%base) + '0'; + uvalue /= base; + } + while(uvalue > 0); + *ndigit = MAXINTLENGTH - i; + return &buf[i]; + } diff --git a/gcc/f/runtime/libI77/fp.h b/gcc/f/runtime/libI77/fp.h new file mode 100644 index 000000000000..40743d79f748 --- /dev/null +++ b/gcc/f/runtime/libI77/fp.h @@ -0,0 +1,28 @@ +#define FMAX 40 +#define EXPMAXDIGS 8 +#define EXPMAX 99999999 +/* FMAX = max number of nonzero digits passed to atof() */ +/* EXPMAX = 10^EXPMAXDIGS - 1 = largest allowed exponent absolute value */ + +#ifdef V10 /* Research Tenth-Edition Unix */ +#include "local.h" +#endif + +/* MAXFRACDIGS and MAXINTDIGS are for wrt_F -- bounds (not necessarily + tight) on the maximum number of digits to the right and left of + * the decimal point. + */ + +#ifdef VAX +#define MAXFRACDIGS 56 +#define MAXINTDIGS 38 +#else +#ifdef CRAY +#define MAXFRACDIGS 9880 +#define MAXINTDIGS 9864 +#else +/* values that suffice for IEEE double */ +#define MAXFRACDIGS 344 +#define MAXINTDIGS 308 +#endif +#endif diff --git a/gcc/f/runtime/libI77/ftell_.c b/gcc/f/runtime/libI77/ftell_.c new file mode 100644 index 000000000000..1bd03be325a9 --- /dev/null +++ b/gcc/f/runtime/libI77/ftell_.c @@ -0,0 +1,46 @@ +#include "f2c.h" +#include "fio.h" + + static FILE * +#ifdef KR_headers +unit_chk(Unit, who) integer Unit; char *who; +#else +unit_chk(integer Unit, char *who) +#endif +{ + if (Unit >= MXUNIT || Unit < 0) + f__fatal(101, who); + return f__units[Unit].ufd; + } + + integer +#ifdef KR_headers +G77_ftell_0 (Unit) integer *Unit; +#else +G77_ftell_0 (integer *Unit) +#endif +{ + FILE *f; + return (f = unit_chk(*Unit, "ftell")) ? ftell(f) : -1L; + } + + integer +#ifdef KR_headers +G77_fseek_0 (Unit, offset, xwhence) integer *Unit, *offset, *xwhence; +#else +G77_fseek_0 (integer *Unit, integer *offset, integer *xwhence) +#endif +{ + FILE *f; + int w = (int)*xwhence; +#ifdef SEEK_SET + static int wohin[3] = { SEEK_SET, SEEK_CUR, SEEK_END }; +#endif + if (w < 0 || w > 2) + w = 0; +#ifdef SEEK_SET + w = wohin[w]; +#endif + return !(f = unit_chk(*Unit, "fseek")) + || fseek(f, *offset, w) ? 1 : 0; + } diff --git a/gcc/f/runtime/libI77/iio.c b/gcc/f/runtime/libI77/iio.c new file mode 100644 index 000000000000..680524f6c1a7 --- /dev/null +++ b/gcc/f/runtime/libI77/iio.c @@ -0,0 +1,147 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +extern char *f__icptr; +char *f__icend; +extern icilist *f__svic; +int f__icnum; +extern int f__hiwater; +z_getc(Void) +{ + if(f__recpos++ < f__svic->icirlen) { + if(f__icptr >= f__icend) err(f__svic->iciend,(EOF),"endfile"); + return(*(unsigned char *)f__icptr++); + } + return '\n'; +} +#ifdef KR_headers +z_putc(c) +#else +z_putc(int c) +#endif +{ + if(f__icptr >= f__icend) err(f__svic->icierr,110,"inwrite"); + if(f__recpos++ < f__svic->icirlen) + *f__icptr++ = c; + else err(f__svic->icierr,110,"recend"); + return 0; +} +z_rnew(Void) +{ + f__icptr = f__svic->iciunit + (++f__icnum)*f__svic->icirlen; + f__recpos = 0; + f__cursor = 0; + f__hiwater = 0; + return 1; +} + + static int +z_endp(Void) +{ + (*f__donewrec)(); + return 0; + } + +#ifdef KR_headers +c_si(a) icilist *a; +#else +c_si(icilist *a) +#endif +{ + if (f__init & 2) + f__fatal (131, "I/O recursion"); + f__init |= 2; + f__elist = (cilist *)a; + f__fmtbuf=a->icifmt; + if(pars_f(f__fmtbuf)<0) + err(a->icierr,100,"startint"); + fmt_bg(); + f__sequential=f__formatted=1; + f__external=0; + f__cblank=f__cplus=f__scale=0; + f__svic=a; + f__icnum=f__recpos=0; + f__cursor = 0; + f__hiwater = 0; + f__icptr = a->iciunit; + f__icend = f__icptr + a->icirlen*a->icirnum; + f__curunit = 0; + f__cf = 0; + return(0); +} + + int +iw_rev(Void) +{ + if(f__workdone) + z_endp(); + f__hiwater = f__recpos = f__cursor = 0; + return(f__workdone=0); + } + +#ifdef KR_headers +integer s_rsfi(a) icilist *a; +#else +integer s_rsfi(icilist *a) +#endif +{ int n; + if(n=c_si(a)) return(n); + f__reading=1; + f__doed=rd_ed; + f__doned=rd_ned; + f__getn=z_getc; + f__dorevert = z_endp; + f__donewrec = z_rnew; + f__doend = z_endp; + return(0); +} + +z_wnew(Void) +{ + if (f__recpos < f__hiwater) { + f__icptr += f__hiwater - f__recpos; + f__recpos = f__hiwater; + } + while(f__recpos++ < f__svic->icirlen) + *f__icptr++ = ' '; + f__recpos = 0; + f__cursor = 0; + f__hiwater = 0; + f__icnum++; + return 1; +} +#ifdef KR_headers +integer s_wsfi(a) icilist *a; +#else +integer s_wsfi(icilist *a) +#endif +{ int n; + if(n=c_si(a)) return(n); + f__reading=0; + f__doed=w_ed; + f__doned=w_ned; + f__putn=z_putc; + f__dorevert = iw_rev; + f__donewrec = z_wnew; + f__doend = z_endp; + return(0); +} +integer e_rsfi(Void) +{ int n; + f__init &= ~2; + n = en_fio(); + f__fmtbuf = NULL; + return(n); +} +integer e_wsfi(Void) +{ + int n; + f__init &= ~2; + n = en_fio(); + f__fmtbuf = NULL; + if(f__icnum >= f__svic->icirnum) + return(n); + while(f__recpos++ < f__svic->icirlen) + *f__icptr++ = ' '; + return(n); +} diff --git a/gcc/f/runtime/libI77/ilnw.c b/gcc/f/runtime/libI77/ilnw.c new file mode 100644 index 000000000000..08ea2be7831e --- /dev/null +++ b/gcc/f/runtime/libI77/ilnw.c @@ -0,0 +1,82 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" +extern char *f__icptr; +extern char *f__icend; +extern icilist *f__svic; +extern int f__icnum; +#ifdef KR_headers +extern int z_putc(); +#else +extern int z_putc(int); +#endif + + static int +z_wSL(Void) +{ + while(f__recpos < f__svic->icirlen) + z_putc(' '); + return z_rnew(); + } + + VOID +#ifdef KR_headers +c_liw(a) icilist *a; +#else +c_liw(icilist *a) +#endif +{ + f__reading = 0; + f__external = 0; + f__formatted = 1; + f__putn = z_putc; + L_len = a->icirlen; + f__donewrec = z_wSL; + f__svic = a; + f__icnum = f__recpos = 0; + f__cursor = 0; + f__cf = 0; + f__curunit = 0; + f__icptr = a->iciunit; + f__icend = f__icptr + a->icirlen*a->icirnum; + f__elist = (cilist *)a; + } + + integer +#ifdef KR_headers +s_wsni(a) icilist *a; +#else +s_wsni(icilist *a) +#endif +{ + cilist ca; + + if(f__init != 1) f_init(); + f__init = 3; + c_liw(a); + ca.cifmt = a->icifmt; + x_wsne(&ca); + z_wSL(); + return 0; + } + + integer +#ifdef KR_headers +s_wsli(a) icilist *a; +#else +s_wsli(icilist *a) +#endif +{ + if(f__init != 1) f_init(); + f__init = 3; + f__lioproc = l_write; + c_liw(a); + return(0); + } + +integer e_wsli(Void) +{ + f__init = 1; + z_wSL(); + return(0); + } diff --git a/gcc/f/runtime/libI77/inquire.c b/gcc/f/runtime/libI77/inquire.c new file mode 100644 index 000000000000..963d4c3e5e8a --- /dev/null +++ b/gcc/f/runtime/libI77/inquire.c @@ -0,0 +1,108 @@ +#include "f2c.h" +#include "fio.h" +#include +#ifdef KR_headers +integer f_inqu(a) inlist *a; +#else +#if defined (MSDOS) && !defined (GO32) +#undef abs +#undef min +#undef max +#include "io.h" +#endif +integer f_inqu(inlist *a) +#endif +{ flag byfile; + int i, n; + unit *p; + char buf[256]; + long x; + if (f__init & 2) + f__fatal (131, "I/O recursion"); + if(a->infile!=NULL) + { byfile=1; + g_char(a->infile,a->infilen,buf); +#ifdef NON_UNIX_STDIO + x = access(buf,0) ? -1 : 0; + for(i=0,p=NULL;iinunitinunit>=0) + { + p= &f__units[a->inunit]; + } + else + { + p=NULL; + } + } + if(a->inex!=NULL) + if(byfile && x != -1 || !byfile && p!=NULL) + *a->inex=1; + else *a->inex=0; + if(a->inopen!=NULL) + if(byfile) *a->inopen=(p!=NULL); + else *a->inopen=(p!=NULL && p->ufd!=NULL); + if(a->innum!=NULL) *a->innum= p-f__units; + if(a->innamed!=NULL) + if(byfile || p!=NULL && p->ufnm!=NULL) + *a->innamed=1; + else *a->innamed=0; + if(a->inname!=NULL) + if(byfile) + b_char(buf,a->inname,a->innamlen); + else if(p!=NULL && p->ufnm!=NULL) + b_char(p->ufnm,a->inname,a->innamlen); + if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL) + if(p->url) + b_char("DIRECT",a->inacc,a->inacclen); + else b_char("SEQUENTIAL",a->inacc,a->inacclen); + if(a->inseq!=NULL) + if(p!=NULL && p->url) + b_char("NO",a->inseq,a->inseqlen); + else b_char("YES",a->inseq,a->inseqlen); + if(a->indir!=NULL) + if(p==NULL || p->url) + b_char("YES",a->indir,a->indirlen); + else b_char("NO",a->indir,a->indirlen); + if(a->infmt!=NULL) + if(p!=NULL && p->ufmt==0) + b_char("UNFORMATTED",a->infmt,a->infmtlen); + else b_char("FORMATTED",a->infmt,a->infmtlen); + if(a->inform!=NULL) + if(p!=NULL && p->ufmt==0) + b_char("NO",a->inform,a->informlen); + else b_char("YES",a->inform,a->informlen); + if(a->inunf) + if(p!=NULL && p->ufmt==0) + b_char("YES",a->inunf,a->inunflen); + else if (p!=NULL) b_char("NO",a->inunf,a->inunflen); + else b_char("UNKNOWN",a->inunf,a->inunflen); + if(a->inrecl!=NULL && p!=NULL) + *a->inrecl=p->url; + if(a->innrec!=NULL && p!=NULL && p->url>0) + *a->innrec=ftell(p->ufd)/p->url+1; + if(a->inblank && p!=NULL && p->ufmt) + if(p->ublnk) + b_char("ZERO",a->inblank,a->inblanklen); + else b_char("NULL",a->inblank,a->inblanklen); + return(0); +} diff --git a/gcc/f/runtime/libI77/lio.h b/gcc/f/runtime/libI77/lio.h new file mode 100644 index 000000000000..012317206aaf --- /dev/null +++ b/gcc/f/runtime/libI77/lio.h @@ -0,0 +1,74 @@ +/* copy of ftypes from the compiler */ +/* variable types + * numeric assumptions: + * int < reals < complexes + * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX + */ + +/* 0-10 retain their old (pre LOGICAL*1, etc.) */ +/* values to allow mixing old and new objects. */ + +#define TYUNKNOWN 0 +#define TYADDR 1 +#define TYSHORT 2 +#define TYLONG 3 +#define TYREAL 4 +#define TYDREAL 5 +#define TYCOMPLEX 6 +#define TYDCOMPLEX 7 +#define TYLOGICAL 8 +#define TYCHAR 9 +#define TYSUBR 10 +#define TYINT1 11 +#define TYLOGICAL1 12 +#define TYLOGICAL2 13 +#ifdef Allow_TYQUAD +#undef TYQUAD +#define TYQUAD 14 +#endif + +#define LINTW 24 +#define LINE 80 +#define LLOGW 2 +#ifdef Old_list_output +#define LLOW 1.0 +#define LHIGH 1.e9 +#define LEFMT " %# .8E" +#define LFFMT " %# .9g" +#else +#define LGFMT "%.9G" +#endif +/* LEFBL 20 should suffice; 24 overcomes a NeXT bug. */ +#define LEFBL 24 + +typedef union +{ + char flchar; + short flshort; + ftnint flint; +#ifdef Allow_TYQUAD + longint fllongint; +#endif + real flreal; + doublereal fldouble; +} flex; +extern int f__scale; +#ifdef KR_headers +extern int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); +extern int l_read(), l_write(); +#else +#ifdef __cplusplus +extern "C" { +#endif +extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint); +extern int l_write(ftnint*, char*, ftnlen, ftnint); +extern void x_wsne(cilist*); +extern int c_le(cilist*), (*l_getc)(void), (*l_ungetc)(int,FILE*); +extern int l_read(ftnint*,char*,ftnlen,ftnint); +extern integer e_rsle(void), e_wsle(void), s_wsne(cilist*); +extern int z_rnew(void); +#ifdef __cplusplus + } +#endif +#endif +extern ftnint L_len; diff --git a/gcc/f/runtime/libI77/lread.c b/gcc/f/runtime/libI77/lread.c new file mode 100644 index 000000000000..3f0642c24cda --- /dev/null +++ b/gcc/f/runtime/libI77/lread.c @@ -0,0 +1,684 @@ +#include +#include "f2c.h" +#include "fio.h" + +/* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */ +/* marks in namelist input a la the Fortran 8X Draft published in */ +/* the May 1989 issue of Fortran Forum. */ + + +extern char *f__fmtbuf; + +#ifdef Allow_TYQUAD +static longint f__llx; +static int quad_read; +#endif + +#ifdef KR_headers +extern double atof(); +extern char *malloc(), *realloc(); +int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); +#else +#undef abs +#undef min +#undef max +#include +int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void), + (*l_ungetc)(int,FILE*); +#endif + +#include "fmt.h" +#include "lio.h" +#include "fp.h" + +int l_eof; + +#define isblnk(x) (f__ltab[x+1]&B) +#define issep(x) (f__ltab[x+1]&SX) +#define isapos(x) (f__ltab[x+1]&AX) +#define isexp(x) (f__ltab[x+1]&EX) +#define issign(x) (f__ltab[x+1]&SG) +#define iswhit(x) (f__ltab[x+1]&WH) +#define SX 1 +#define B 2 +#define AX 4 +#define EX 8 +#define SG 16 +#define WH 32 +char f__ltab[128+1] = { /* offset one for EOF */ + 0, + 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 +}; + +#ifdef ungetc + static int +#ifdef KR_headers +un_getc(x,f__cf) int x; FILE *f__cf; +#else +un_getc(int x, FILE *f__cf) +#endif +{ return ungetc(x,f__cf); } +#else +#define un_getc ungetc +#ifdef KR_headers + extern int ungetc(); +#else +extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ +#endif +#endif + +t_getc(Void) +{ int ch; + if(f__curunit->uend) return(EOF); + if((ch=getc(f__cf))!=EOF) return(ch); + if(feof(f__cf)) + f__curunit->uend = l_eof = 1; + return(EOF); +} +integer e_rsle(Void) +{ + int ch; + f__init = 1; + if(f__curunit->uend) return(0); + while((ch=t_getc())!='\n') + if (ch == EOF) { + if(feof(f__cf)) + f__curunit->uend = l_eof = 1; + return EOF; + } + return(0); +} + +flag f__lquit; +int f__lcount,f__ltype,nml_read; +char *f__lchar; +double f__lx,f__ly; +#define ERR(x) if(n=(x)) {f__init &= ~2; return(n);} +#define GETC(x) (x=(*l_getc)()) +#define Ungetc(x,y) (*l_ungetc)(x,y) + +#ifdef KR_headers +l_R(poststar) int poststar; +#else +l_R(int poststar) +#endif +{ + char s[FMAX+EXPMAXDIGS+4]; + register int ch; + register char *sp, *spe, *sp1; + long e, exp; + int havenum, havestar, se; + + if (!poststar) { + if (f__lcount > 0) + return(0); + f__lcount = 1; + } +#ifdef Allow_TYQUAD + f__llx = 0; +#endif + f__ltype = 0; + exp = 0; + havestar = 0; +retry: + sp1 = sp = s; + spe = sp + FMAX; + havenum = 0; + + switch(GETC(ch)) { + case '-': *sp++ = ch; sp1++; spe++; + case '+': + GETC(ch); + } + while(ch == '0') { + ++havenum; + GETC(ch); + } + while(isdigit(ch)) { + if (sp < spe) *sp++ = ch; + else ++exp; + GETC(ch); + } + if (ch == '*' && !poststar) { + if (sp == sp1 || exp || *s == '-') { + errfl(f__elist->cierr,112,"bad repetition count"); + } + poststar = havestar = 1; + *sp = 0; + f__lcount = atoi(s); + goto retry; + } + if (ch == '.') { + GETC(ch); + if (sp == sp1) + while(ch == '0') { + ++havenum; + --exp; + GETC(ch); + } + while(isdigit(ch)) { + if (sp < spe) + { *sp++ = ch; --exp; } + GETC(ch); + } + } + havenum += sp - sp1; + se = 0; + if (issign(ch)) + goto signonly; + if (havenum && isexp(ch)) { + GETC(ch); + if (issign(ch)) { +signonly: + if (ch == '-') se = 1; + GETC(ch); + } + if (!isdigit(ch)) { +bad: + errfl(f__elist->cierr,112,"exponent field"); + } + + e = ch - '0'; + while(isdigit(GETC(ch))) { + e = 10*e + ch - '0'; + if (e > EXPMAX) + goto bad; + } + if (se) + exp -= e; + else + exp += e; + } + (void) Ungetc(ch, f__cf); + if (sp > sp1) { + ++havenum; + while(*--sp == '0') + ++exp; + if (exp) + sprintf(sp+1, "e%ld", exp); + else + sp[1] = 0; + f__lx = atof(s); +#ifdef Allow_TYQUAD + if (quad_read && (se = sp - sp1 + exp) > 14 && se < 20) { + /* Assuming 64-bit longint and 32-bit long. */ + if (exp < 0) + sp += exp; + if (sp1 <= sp) { + f__llx = *sp1 - '0'; + while(++sp1 <= sp) + f__llx = 10*f__llx + (*sp1 - '0'); + } + while(--exp >= 0) + f__llx *= 10; + if (*s == '-') + f__llx = -f__llx; + } +#endif + } + else + f__lx = 0.; + if (havenum) + f__ltype = TYLONG; + else + switch(ch) { + case ',': + case '/': + break; + default: + if (havestar && ( ch == ' ' + ||ch == '\t' + ||ch == '\n')) + break; + if (nml_read > 1) { + f__lquit = 2; + return 0; + } + errfl(f__elist->cierr,112,"invalid number"); + } + return 0; + } + + static int +#ifdef KR_headers +rd_count(ch) register int ch; +#else +rd_count(register int ch) +#endif +{ + if (ch < '0' || ch > '9') + return 1; + f__lcount = ch - '0'; + while(GETC(ch) >= '0' && ch <= '9') + f__lcount = 10*f__lcount + ch - '0'; + Ungetc(ch,f__cf); + return f__lcount <= 0; + } + +l_C(Void) +{ int ch, nml_save; + double lz; + if(f__lcount>0) return(0); + f__ltype=0; + GETC(ch); + if(ch!='(') + { + if (nml_read > 1 && (ch < '0' || ch > '9')) { + Ungetc(ch,f__cf); + f__lquit = 2; + return 0; + } + if (rd_count(ch)) + if(!f__cf || !feof(f__cf)) + errfl(f__elist->cierr,112,"complex format"); + else + err(f__elist->cierr,(EOF),"lread"); + if(GETC(ch)!='*') + { + if(!f__cf || !feof(f__cf)) + errfl(f__elist->cierr,112,"no star"); + else + err(f__elist->cierr,(EOF),"lread"); + } + if(GETC(ch)!='(') + { Ungetc(ch,f__cf); + return(0); + } + } + else + f__lcount = 1; + while(iswhit(GETC(ch))); + Ungetc(ch,f__cf); + nml_save = nml_read; + nml_read = 0; + if (ch = l_R(1)) + return ch; + if (!f__ltype) + errfl(f__elist->cierr,112,"no real part"); + lz = f__lx; + while(iswhit(GETC(ch))); + if(ch!=',') + { (void) Ungetc(ch,f__cf); + errfl(f__elist->cierr,112,"no comma"); + } + while(iswhit(GETC(ch))); + (void) Ungetc(ch,f__cf); + if (ch = l_R(1)) + return ch; + if (!f__ltype) + errfl(f__elist->cierr,112,"no imaginary part"); + while(iswhit(GETC(ch))); + if(ch!=')') errfl(f__elist->cierr,112,"no )"); + f__ly = f__lx; + f__lx = lz; +#ifdef Allow_TYQUAD + f__llx = 0; +#endif + nml_read = nml_save; + return(0); +} +l_L(Void) +{ + int ch; + if(f__lcount>0) return(0); + f__lcount = 1; + f__ltype=0; + GETC(ch); + if(isdigit(ch)) + { + rd_count(ch); + if(GETC(ch)!='*') + if(!f__cf || !feof(f__cf)) + errfl(f__elist->cierr,112,"no star"); + else + err(f__elist->cierr,(EOF),"lread"); + GETC(ch); + } + if(ch == '.') GETC(ch); + switch(ch) + { + case 't': + case 'T': + f__lx=1; + break; + case 'f': + case 'F': + f__lx=0; + break; + default: + if(isblnk(ch) || issep(ch) || ch==EOF) + { (void) Ungetc(ch,f__cf); + return(0); + } + if (nml_read > 1) { + Ungetc(ch,f__cf); + f__lquit = 2; + return 0; + } + errfl(f__elist->cierr,112,"logical"); + } + f__ltype=TYLONG; + while(!issep(GETC(ch)) && ch!=EOF); + (void) Ungetc(ch, f__cf); + return(0); +} +#define BUFSIZE 128 +l_CHAR(Void) +{ int ch,size,i; + static char rafail[] = "realloc failure"; + char quote,*p; + if(f__lcount>0) return(0); + f__ltype=0; + if(f__lchar!=NULL) free(f__lchar); + size=BUFSIZE; + p=f__lchar = (char *)malloc((unsigned int)size); + if(f__lchar == NULL) + errfl(f__elist->cierr,113,"no space"); + + GETC(ch); + if(isdigit(ch)) { + /* allow Fortran 8x-style unquoted string... */ + /* either find a repetition count or the string */ + f__lcount = ch - '0'; + *p++ = ch; + for(i = 1;;) { + switch(GETC(ch)) { + case '*': + if (f__lcount == 0) { + f__lcount = 1; +#ifndef F8X_NML_ELIDE_QUOTES + if (nml_read) + goto no_quote; +#endif + goto noquote; + } + p = f__lchar; + goto have_lcount; + case ',': + case ' ': + case '\t': + case '\n': + case '/': + Ungetc(ch,f__cf); + /* no break */ + case EOF: + f__lcount = 1; + f__ltype = TYCHAR; + return *p = 0; + } + if (!isdigit(ch)) { + f__lcount = 1; +#ifndef F8X_NML_ELIDE_QUOTES + if (nml_read) { + no_quote: + errfl(f__elist->cierr,112, + "undelimited character string"); + } +#endif + goto noquote; + } + *p++ = ch; + f__lcount = 10*f__lcount + ch - '0'; + if (++i == size) { + f__lchar = (char *)realloc(f__lchar, + (unsigned int)(size += BUFSIZE)); + if(f__lchar == NULL) + errfl(f__elist->cierr,113,rafail); + p = f__lchar + i; + } + } + } + else (void) Ungetc(ch,f__cf); + have_lcount: + if(GETC(ch)=='\'' || ch=='"') quote=ch; + else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) { + Ungetc(ch,f__cf); + return 0; + } +#ifndef F8X_NML_ELIDE_QUOTES + else if (nml_read > 1) { + Ungetc(ch,f__cf); + f__lquit = 2; + return 0; + } +#endif + else { + /* Fortran 8x-style unquoted string */ + *p++ = ch; + for(i = 1;;) { + switch(GETC(ch)) { + case ',': + case ' ': + case '\t': + case '\n': + case '/': + Ungetc(ch,f__cf); + /* no break */ + case EOF: + f__ltype = TYCHAR; + return *p = 0; + } + noquote: + *p++ = ch; + if (++i == size) { + f__lchar = (char *)realloc(f__lchar, + (unsigned int)(size += BUFSIZE)); + if(f__lchar == NULL) + errfl(f__elist->cierr,113,rafail); + p = f__lchar + i; + } + } + } + f__ltype=TYCHAR; + for(i=0;;) + { while(GETC(ch)!=quote && ch!='\n' + && ch!=EOF && ++icierr,113,rafail); + p=f__lchar+i-1; + *p++ = ch; + } + else if(ch==EOF) return(EOF); + else if(ch=='\n') + { if(*(p-1) != '\\') continue; + i--; + p--; + if(++iciunit>=MXUNIT || a->ciunit<0) + err(a->cierr,101,"stler"); + f__scale=f__recpos=0; + f__elist=a; + f__curunit = &f__units[a->ciunit]; + if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) + err(a->cierr,102,"lio"); + f__cf=f__curunit->ufd; + if(!f__curunit->ufmt) err(a->cierr,103,"lio"); + return(0); +} +#ifdef KR_headers +l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; +#else +l_read(ftnint *number, char *ptr, ftnlen len, ftnint type) +#endif +{ +#define Ptr ((flex *)ptr) + int i,n,ch; + doublereal *yy; + real *xx; + for(i=0;i<*number;i++) + { + if(f__lquit) return(0); + if(l_eof) + err(f__elist->ciend, EOF, "list in"); + if(f__lcount == 0) { + f__ltype = 0; + for(;;) { + GETC(ch); + switch(ch) { + case EOF: + err(f__elist->ciend,(EOF),"list in"); + case ' ': + case '\t': + case '\n': + continue; + case '/': + f__lquit = 1; + goto loopend; + case ',': + f__lcount = 1; + goto loopend; + default: + (void) Ungetc(ch, f__cf); + goto rddata; + } + } + } + rddata: + switch((int)type) + { + case TYINT1: + case TYSHORT: + case TYLONG: + case TYREAL: + case TYDREAL: + ERR(l_R(0)); + break; +#ifdef TYQUAD + case TYQUAD: + quad_read = 1; + n = l_R(0); + quad_read = 0; + ERR(n); + break; +#endif + case TYCOMPLEX: + case TYDCOMPLEX: + ERR(l_C()); + break; + case TYLOGICAL1: + case TYLOGICAL2: + case TYLOGICAL: + ERR(l_L()); + break; + case TYCHAR: + ERR(l_CHAR()); + break; + } + while (GETC(ch) == ' ' || ch == '\t'); + if (ch != ',' || f__lcount > 1) + Ungetc(ch,f__cf); + loopend: + if(f__lquit) return(0); + if(f__cf && ferror(f__cf)) { + clearerr(f__cf); + errfl(f__elist->cierr,errno,"list in"); + } + if(f__ltype==0) goto bump; + switch((int)type) + { + case TYINT1: + case TYLOGICAL1: + Ptr->flchar = (char)f__lx; + break; + case TYLOGICAL2: + case TYSHORT: + Ptr->flshort = (short)f__lx; + break; + case TYLOGICAL: + case TYLONG: + Ptr->flint=f__lx; + break; +#ifdef Allow_TYQUAD + case TYQUAD: + if (!(Ptr->fllongint = f__llx)) + Ptr->fllongint = f__lx; + break; +#endif + case TYREAL: + Ptr->flreal=f__lx; + break; + case TYDREAL: + Ptr->fldouble=f__lx; + break; + case TYCOMPLEX: + xx=(real *)ptr; + *xx++ = f__lx; + *xx = f__ly; + break; + case TYDCOMPLEX: + yy=(doublereal *)ptr; + *yy++ = f__lx; + *yy = f__ly; + break; + case TYCHAR: + b_char(f__lchar,ptr,len); + break; + } + bump: + if(f__lcount>0) f__lcount--; + ptr += len; + if (nml_read) + nml_read++; + } + return(0); +#undef Ptr +} +#ifdef KR_headers +integer s_rsle(a) cilist *a; +#else +integer s_rsle(cilist *a) +#endif +{ + int n; + + if(n=c_le(a)) return(n); + f__reading=1; + f__external=1; + f__formatted=1; + f__lioproc = l_read; + f__lquit = 0; + f__lcount = 0; + l_eof = 0; + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,"read start"); + if(f__curunit->uend) + err(f__elist->ciend,(EOF),"read start"); + l_getc = t_getc; + l_ungetc = un_getc; + f__doend = xrd_SL; + return(0); +} diff --git a/gcc/f/runtime/libI77/lwrite.c b/gcc/f/runtime/libI77/lwrite.c new file mode 100644 index 000000000000..5da7dfbb972a --- /dev/null +++ b/gcc/f/runtime/libI77/lwrite.c @@ -0,0 +1,310 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#include "lio.h" + +ftnint L_len; +int f__Aquote; + + static VOID +donewrec(Void) +{ + if (f__recpos) + (*f__donewrec)(); + } + +#ifdef KR_headers +t_putc(c) +#else +t_putc(int c) +#endif +{ + f__recpos++; + putc(c,f__cf); + return(0); +} + static VOID +#ifdef KR_headers +lwrt_I(n) longint n; +#else +lwrt_I(longint n) +#endif +{ + char *p; + int ndigit, sign; + + p = f__icvt(n, &ndigit, &sign, 10); + if(f__recpos + ndigit >= L_len) + donewrec(); + PUT(' '); + if (sign) + PUT('-'); + while(*p) + PUT(*p++); +} + static VOID +#ifdef KR_headers +lwrt_L(n, len) ftnint n; ftnlen len; +#else +lwrt_L(ftnint n, ftnlen len) +#endif +{ + if(f__recpos+LLOGW>=L_len) + donewrec(); + wrt_L((Uint *)&n,LLOGW, len); +} + static VOID +#ifdef KR_headers +lwrt_A(p,len) char *p; ftnlen len; +#else +lwrt_A(char *p, ftnlen len) +#endif +{ + int a; + char *p1, *pe; + + a = 0; + pe = p + len; + if (f__Aquote) { + a = 3; + if (len > 1 && p[len-1] == ' ') { + while(--len > 1 && p[len-1] == ' '); + pe = p + len; + } + p1 = p; + while(p1 < pe) + if (*p1++ == '\'') + a++; + } + if(f__recpos+len+a >= L_len) + donewrec(); + if (a +#ifndef OMIT_BLANK_CC + || !f__recpos +#endif + ) + PUT(' '); + if (a) { + PUT('\''); + while(p < pe) { + if (*p == '\'') + PUT('\''); + PUT(*p++); + } + PUT('\''); + } + else + while(p < pe) + PUT(*p++); +} + + static int +#ifdef KR_headers +l_g(buf, n) char *buf; double n; +#else +l_g(char *buf, double n) +#endif +{ +#ifdef Old_list_output + doublereal absn; + char *fmt; + + absn = n; + if (absn < 0) + absn = -absn; + fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT; +#ifdef USE_STRLEN + sprintf(buf, fmt, n); + return strlen(buf); +#else + return sprintf(buf, fmt, n); +#endif + +#else + register char *b, c, c1; + + b = buf; + *b++ = ' '; + if (n < 0) { + *b++ = '-'; + n = -n; + } + else + *b++ = ' '; + if (n == 0) { + *b++ = '0'; + *b++ = '.'; + *b = 0; + goto f__ret; + } + sprintf(b, LGFMT, n); + switch(*b) { +#ifndef WANT_LEAD_0 + case '0': + while(b[0] = b[1]) + b++; + break; +#endif + case 'i': + case 'I': + /* Infinity */ + case 'n': + case 'N': + /* NaN */ + while(*++b); + break; + + default: + /* Fortran 77 insists on having a decimal point... */ + for(;; b++) + switch(*b) { + case 0: + *b++ = '.'; + *b = 0; + goto f__ret; + case '.': + while(*++b); + goto f__ret; + case 'E': + for(c1 = '.', c = 'E'; *b = c1; + c1 = c, c = *++b); + goto f__ret; + } + } + f__ret: + return b - buf; +#endif + } + + static VOID +#ifdef KR_headers +l_put(s) register char *s; +#else +l_put(register char *s) +#endif +{ +#ifdef KR_headers + register int c, (*pn)() = f__putn; +#else + register int c, (*pn)(int) = f__putn; +#endif + while(c = *s++) + (*pn)(c); + } + + static VOID +#ifdef KR_headers +lwrt_F(n) double n; +#else +lwrt_F(double n) +#endif +{ + char buf[LEFBL]; + + if(f__recpos + l_g(buf,n) >= L_len) + donewrec(); + l_put(buf); +} + static VOID +#ifdef KR_headers +lwrt_C(a,b) double a,b; +#else +lwrt_C(double a, double b) +#endif +{ + char *ba, *bb, bufa[LEFBL], bufb[LEFBL]; + int al, bl; + + al = l_g(bufa, a); + for(ba = bufa; *ba == ' '; ba++) + --al; + bl = l_g(bufb, b) + 1; /* intentionally high by 1 */ + for(bb = bufb; *bb == ' '; bb++) + --bl; + if(f__recpos + al + bl + 3 >= L_len) + donewrec(); +#ifdef OMIT_BLANK_CC + else +#endif + PUT(' '); + PUT('('); + l_put(ba); + PUT(','); + if (f__recpos + bl >= L_len) { + (*f__donewrec)(); +#ifndef OMIT_BLANK_CC + PUT(' '); +#endif + } + l_put(bb); + PUT(')'); +} +#ifdef KR_headers +l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; +#else +l_write(ftnint *number, char *ptr, ftnlen len, ftnint type) +#endif +{ +#define Ptr ((flex *)ptr) + int i; + longint x; + double y,z; + real *xx; + doublereal *yy; + for(i=0;i< *number; i++) + { + switch((int)type) + { + default: f__fatal(204,"unknown type in lio"); + case TYINT1: + x = Ptr->flchar; + goto xint; + case TYSHORT: + x=Ptr->flshort; + goto xint; +#ifdef Allow_TYQUAD + case TYQUAD: + x = Ptr->fllongint; + goto xint; +#endif + case TYLONG: + x=Ptr->flint; + xint: lwrt_I(x); + break; + case TYREAL: + y=Ptr->flreal; + goto xfloat; + case TYDREAL: + y=Ptr->fldouble; + xfloat: lwrt_F(y); + break; + case TYCOMPLEX: + xx= &Ptr->flreal; + y = *xx++; + z = *xx; + goto xcomplex; + case TYDCOMPLEX: + yy = &Ptr->fldouble; + y= *yy++; + z = *yy; + xcomplex: + lwrt_C(y,z); + break; + case TYLOGICAL1: + x = Ptr->flchar; + goto xlog; + case TYLOGICAL2: + x = Ptr->flshort; + goto xlog; + case TYLOGICAL: + x = Ptr->flint; + xlog: lwrt_L(Ptr->flint, len); + break; + case TYCHAR: + lwrt_A(ptr,len); + break; + } + ptr += len; + } + return(0); +} diff --git a/gcc/f/runtime/libI77/makefile.netlib b/gcc/f/runtime/libI77/makefile.netlib new file mode 100644 index 000000000000..edba1fe8569f --- /dev/null +++ b/gcc/f/runtime/libI77/makefile.netlib @@ -0,0 +1,104 @@ +.SUFFIXES: .c .o +CC = cc +CFLAGS = -O +SHELL = /bin/sh + +# compile, then strip unnecessary symbols +.c.o: + $(CC) -c -DSkip_f2c_Undefs $(CFLAGS) $*.c + ld -r -x -o $*.xxx $*.o + mv $*.xxx $*.o +## Under Solaris (and other systems that do not understand ld -x), +## omit -x in the ld line above. +## If your system does not have the ld command, comment out +## or remove both the ld and mv lines above. + +OBJ = Version.o backspace.o close.o dfe.o dolio.o due.o endfile.o err.o \ + fmt.o fmtlib.o ftell_.o iio.o ilnw.o inquire.o lread.o lwrite.o \ + open.o rdfmt.o rewind.o rsfe.o rsli.o rsne.o sfe.o sue.o typesize.o \ + uio.o util.o wref.o wrtfmt.o wsfe.o wsle.o wsne.o xwsne.o +libI77.a: $(OBJ) + ar r libI77.a $? + -ranlib libI77.a + +### If your system lacks ranlib, you don't need it; see README. + +install: libI77.a + cp libI77.a /usr/lib/libI77.a + ranlib /usr/lib/libI77.a + +Version.o: Version.c + $(CC) -c Version.c + +# To compile with C++, first "make f2c.h" +f2c.h: f2ch.add + cat /usr/include/f2c.h f2ch.add >f2c.h + + +clean: + rm -f $(OBJ) libI77.a + +clobber: clean + rm -f libI77.a + +backspace.o: fio.h +close.o: fio.h +dfe.o: fio.h +dfe.o: fmt.h +due.o: fio.h +endfile.o: fio.h rawio.h +err.o: fio.h rawio.h +fmt.o: fio.h +fmt.o: fmt.h +ftell_.o: fio.h +iio.o: fio.h +iio.o: fmt.h +ilnw.o: fio.h +ilnw.o: lio.h +inquire.o: fio.h +lread.o: fio.h +lread.o: fmt.h +lread.o: lio.h +lread.o: fp.h +lwrite.o: fio.h +lwrite.o: fmt.h +lwrite.o: lio.h +open.o: fio.h rawio.h +rdfmt.o: fio.h +rdfmt.o: fmt.h +rdfmt.o: fp.h +rewind.o: fio.h +rsfe.o: fio.h +rsfe.o: fmt.h +rsli.o: fio.h +rsli.o: lio.h +rsne.o: fio.h +rsne.o: lio.h +sfe.o: fio.h +sue.o: fio.h +uio.o: fio.h +util.o: fio.h +wref.o: fio.h +wref.o: fmt.h +wref.o: fp.h +wrtfmt.o: fio.h +wrtfmt.o: fmt.h +wsfe.o: fio.h +wsfe.o: fmt.h +wsle.o: fio.h +wsle.o: fmt.h +wsle.o: lio.h +wsne.o: fio.h +wsne.o: lio.h +xwsne.o: fio.h +xwsne.o: lio.h +xwsne.o: fmt.h + +check: + xsum Notice README Version.c backspace.c close.c dfe.c dolio.c \ + due.c endfile.c err.c f2ch.add fio.h fmt.c fmt.h fmtlib.c fp.h \ + ftell_.c iio.c ilnw.c inquire.c lio.h lread.c lwrite.c makefile \ + open.c rawio.h rdfmt.c rewind.c rsfe.c rsli.c rsne.c sfe.c sue.c \ + typesize.c uio.c util.c wref.c wrtfmt.c wsfe.c wsle.c wsne.c \ + xwsne.c >zap + cmp zap libI77.xsum && rm zap || diff libI77.xsum zap diff --git a/gcc/f/runtime/libI77/open.c b/gcc/f/runtime/libI77/open.c new file mode 100644 index 000000000000..b08302b5b2c6 --- /dev/null +++ b/gcc/f/runtime/libI77/open.c @@ -0,0 +1,245 @@ +#ifndef NON_UNIX_STDIO +#include +#include +#endif +#include "f2c.h" +#include "fio.h" +#include +#include "rawio.h" + +#ifdef KR_headers +extern char *malloc(), *mktemp(); +extern integer f_clos(); +#else +#undef abs +#undef min +#undef max +#include +extern int f__canseek(FILE*); +extern integer f_clos(cllist*); +#endif + +#ifdef NON_ANSI_RW_MODES +char *f__r_mode[2] = {"r", "r"}; +char *f__w_mode[4] = {"w", "w", "r+w", "r+w"}; +#else +char *f__r_mode[2] = {"rb", "r"}; +char *f__w_mode[4] = {"wb", "w", "r+b", "r+"}; +#endif + +#ifdef KR_headers +f__isdev(s) char *s; +#else +f__isdev(char *s) +#endif +{ +#ifdef NON_UNIX_STDIO + int i, j; + + i = open(s,O_RDONLY); + if (i == -1) + return 0; + j = isatty(i); + close(i); + return j; +#else + struct stat x; + + if(stat(s, &x) == -1) return(0); +#ifdef S_IFMT + switch(x.st_mode&S_IFMT) { + case S_IFREG: + case S_IFDIR: + return(0); + } +#else +#ifdef S_ISREG + /* POSIX version */ + if(S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) + return(0); + else +#else + Help! How does stat work on this system? +#endif +#endif + return(1); +#endif +} +#ifdef KR_headers +integer f_open(a) olist *a; +#else +integer f_open(olist *a) +#endif +{ unit *b; + integer rv; + char buf[256], *s; + cllist x; + int ufmt; +#ifdef NON_UNIX_STDIO + FILE *tf; +#else + int n; + struct stat stb; +#endif + if(f__init != 1) f_init(); + if(a->ounit>=MXUNIT || a->ounit<0) + err(a->oerr,101,"open"); + f__curunit = b = &f__units[a->ounit]; + if(b->ufd) { + if(a->ofnm==0) + { + same: if (a->oblnk) + b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z'; + return(0); + } +#ifdef NON_UNIX_STDIO + if (b->ufnm + && strlen(b->ufnm) == a->ofnmlen + && !strncmp(b->ufnm, b->ufnm, (unsigned)a->ofnmlen)) + goto same; +#else + g_char(a->ofnm,a->ofnmlen,buf); + if (f__inode(buf,&n) == b->uinode && n == b->udev) + goto same; +#endif + x.cunit=a->ounit; + x.csta=0; + x.cerr=a->oerr; + if ((rv = f_clos(&x)) != 0) + return rv; + } + b->url = (int)a->orl; + b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z'); + if(a->ofm==0) + { if(b->url>0) b->ufmt=0; + else b->ufmt=1; + } + else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1; + else b->ufmt=0; + ufmt = b->ufmt; +#ifdef url_Adjust + if (b->url && !ufmt) + url_Adjust(b->url); +#endif + if (a->ofnm) { + g_char(a->ofnm,a->ofnmlen,buf); + if (!buf[0]) + err(a->oerr,107,"open"); + } + else + sprintf(buf, "fort.%ld", a->ounit); + b->uscrtch = 0; + switch(a->osta ? *a->osta : 'u') + { + case 'o': + case 'O': +#ifdef NON_UNIX_STDIO + if(access(buf,0)) +#else + if(stat(buf,&stb)) +#endif + err(a->oerr,errno,"open"); + break; + case 's': + case 'S': + b->uscrtch=1; +#ifdef _POSIX_SOURCE + tmpnam(buf); +#else + (void) strcpy(buf,"tmp.FXXXXXX"); + (void) mktemp(buf); +#endif + goto replace; + case 'n': + case 'N': +#ifdef NON_UNIX_STDIO + if(!access(buf,0)) +#else + if(!stat(buf,&stb)) +#endif + err(a->oerr,128,"open"); + /* no break */ + case 'r': /* Fortran 90 replace option */ + case 'R': + replace: +#ifdef NON_UNIX_STDIO + if (tf = fopen(buf,f__w_mode[0])) + fclose(tf); +#else + (void) close(creat(buf, 0666)); +#endif + } + + b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1)); + if(b->ufnm==NULL) err(a->oerr,113,"no space"); + (void) strcpy(b->ufnm,buf); + b->uend=0; + b->uwrt = 0; +#ifdef NON_UNIX_STDIO + if ((s = a->oacc) && (*s == 'd' || *s == 'D')) + ufmt = 0; +#endif + if(f__isdev(buf)) + { b->ufd = fopen(buf,f__r_mode[ufmt]); + if(b->ufd==NULL) err(a->oerr,errno,buf); + } + else { + if(!(b->ufd = fopen(buf, f__r_mode[ufmt]))) { +#ifdef NON_UNIX_STDIO + if (b->ufd = fopen(buf, f__w_mode[ufmt|2])) + b->uwrt = 2; + else if (b->ufd = fopen(buf, f__w_mode[ufmt])) + b->uwrt = 1; + else +#else + if ((n = open(buf,O_WRONLY)) >= 0) + b->uwrt = 2; + else { + n = creat(buf, 0666); + b->uwrt = 1; + } + if (n < 0 + || (b->ufd = fdopen(n, f__w_mode[ufmt])) == NULL) +#endif + err(a->oerr, errno, "open"); + } + } + b->useek=f__canseek(b->ufd); +#ifndef NON_UNIX_STDIO + if((b->uinode=f__inode(buf,&b->udev))==-1) + err(a->oerr,108,"open"); +#endif + if(b->useek) + if (a->orl) + rewind(b->ufd); + else if ((s = a->oacc) && (*s == 'a' || *s == 'A') + && fseek(b->ufd, 0L, SEEK_END)) + err(a->oerr,129,"open"); + return(0); +} +#ifdef KR_headers +fk_open(seq,fmt,n) ftnint n; +#else +fk_open(int seq, int fmt, ftnint n) +#endif +{ char nbuf[10]; + olist a; + int rtn; + int save_init; + + (void) sprintf(nbuf,"fort.%ld",n); + a.oerr=1; + a.ounit=n; + a.ofnm=nbuf; + a.ofnmlen=strlen(nbuf); + a.osta=NULL; + a.oacc= seq==SEQ?"s":"d"; + a.ofm = fmt==FMT?"f":"u"; + a.orl = seq==DIR?1:0; + a.oblnk=NULL; + save_init = f__init; + f__init &= ~2; + rtn = f_open(&a); + f__init = save_init | 1; + return rtn; +} diff --git a/gcc/f/runtime/libI77/rawio.h b/gcc/f/runtime/libI77/rawio.h new file mode 100644 index 000000000000..cc5cab8b7bb2 --- /dev/null +++ b/gcc/f/runtime/libI77/rawio.h @@ -0,0 +1,45 @@ +#ifdef KR_headers +extern FILE *fdopen(); +#else +#if defined (MSDOS) && !defined (GO32) +#include "io.h" +#ifndef WATCOM +#define close _close +#define creat _creat +#define open _open +#define read _read +#define write _write +#endif /*WATCOM*/ +#endif /*MSDOS*/ +#ifdef __cplusplus +extern "C" { +#endif +#if !(defined (MSDOS) && !defined (GO32)) +#ifdef OPEN_DECL +extern int creat(const char*,int), open(const char*,int); +#endif +extern int close(int); +extern int read(int,void*,size_t), write(int,void*,size_t); +extern int unlink(const char*); +#ifndef _POSIX_SOURCE +#ifndef NON_UNIX_STDIO +extern FILE *fdopen(int, const char*); +#endif +#endif +#endif /*KR_HEADERS*/ + +extern char *mktemp(char*); + +#ifdef __cplusplus + } +#endif +#endif + +#ifndef NO_FCNTL +#include +#endif + +#ifndef O_WRONLY +#define O_RDONLY 0 +#define O_WRONLY 1 +#endif diff --git a/gcc/f/runtime/libI77/rdfmt.c b/gcc/f/runtime/libI77/rdfmt.c new file mode 100644 index 000000000000..0d8c2b4d9ca6 --- /dev/null +++ b/gcc/f/runtime/libI77/rdfmt.c @@ -0,0 +1,476 @@ +#include +#include "f2c.h" +#include "fio.h" + +extern int f__cursor; +#ifdef KR_headers +extern double atof(); +#else +#undef abs +#undef min +#undef max +#include +#endif + +#include "fmt.h" +#include "fp.h" + + static int +#ifdef KR_headers +rd_Z(n,w,len) Uint *n; ftnlen len; +#else +rd_Z(Uint *n, int w, ftnlen len) +#endif +{ + long x[9]; + char *s, *s0, *s1, *se, *t; + int ch, i, w1, w2; + static char hex[256]; + static int one = 1; + int bad = 0; + + if (!hex['0']) { + s = "0123456789"; + while(ch = *s++) + hex[ch] = ch - '0' + 1; + s = "ABCDEF"; + while(ch = *s++) + hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11; + } + s = s0 = (char *)x; + s1 = (char *)&x[4]; + se = (char *)&x[8]; + if (len > 4*sizeof(long)) + return errno = 117; + while (w) { + GET(ch); + if (ch==',' || ch=='\n') + break; + w--; + if (ch > ' ') { + if (!hex[ch & 0xff]) + bad++; + *s++ = ch; + if (s == se) { + /* discard excess characters */ + for(t = s0, s = s1; t < s1;) + *t++ = *s++; + s = s1; + } + } + } + if (bad) + return errno = 115; + w = (int)len; + w1 = s - s0; + w2 = w1+1 >> 1; + t = (char *)n; + if (*(char *)&one) { + /* little endian */ + t += w - 1; + i = -1; + } + else + i = 1; + for(; w > w2; t += i, --w) + *t = 0; + if (!w) + return 0; + if (w < w2) + s0 = s - (w << 1); + else if (w1 & 1) { + *t = hex[*s0++ & 0xff] - 1; + if (!--w) + return 0; + t += i; + } + do { + *t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1; + t += i; + s0 += 2; + } + while(--w); + return 0; + } + + static int +#ifdef KR_headers +rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base; +#else +rd_I(Uint *n, int w, ftnlen len, register int base) +#endif +{ longint x; + int sign,ch; + char s[84], *ps; + ps=s; x=0; + while (w) + { + GET(ch); + if (ch==',' || ch=='\n') break; + *ps=ch; ps++; w--; + } + *ps='\0'; + ps=s; + while (*ps==' ') ps++; + if (*ps=='-') { sign=1; ps++; } + else { sign=0; if (*ps=='+') ps++; } +loop: while (*ps>='0' && *ps<='9') { x=x*base+(*ps-'0'); ps++; } + if (*ps==' ') {if (f__cblank) x *= base; ps++; goto loop;} + if(sign) x = -x; + if(len==sizeof(integer)) n->il=x; + else if(len == sizeof(char)) n->ic = (char)x; +#ifdef Allow_TYQUAD + else if (len == sizeof(longint)) n->ili = x; +#endif + else n->is = (short)x; + if (*ps) return(errno=115); else return(0); +} + static int +#ifdef KR_headers +rd_L(n,w,len) ftnint *n; ftnlen len; +#else +rd_L(ftnint *n, int w, ftnlen len) +#endif +{ int ch, lv; + char s[84], *ps; + ps=s; + while (w) { + GET(ch); + if (ch==','||ch=='\n') break; + *ps=ch; + ps++; w--; + } + *ps='\0'; + ps=s; while (*ps==' ') ps++; + if (*ps=='.') ps++; + if (*ps=='t' || *ps == 'T') + lv = 1; + else if (*ps == 'f' || *ps == 'F') + lv = 0; + else return(errno=116); + switch(len) { + case sizeof(char): *(char *)n = (char)lv; break; + case sizeof(short): *(short *)n = (short)lv; break; + default: *n = lv; + } + return 0; +} + + static int +#ifdef KR_headers +rd_F(p, w, d, len) ufloat *p; ftnlen len; +#else +rd_F(ufloat *p, int w, int d, ftnlen len) +#endif +{ + char s[FMAX+EXPMAXDIGS+4]; + register int ch; + register char *sp, *spe, *sp1; + double x; + int scale1, se; + long e, exp; + + sp1 = sp = s; + spe = sp + FMAX; + exp = -d; + x = 0.; + + do { + GET(ch); + w--; + } while (ch == ' ' && w); + switch(ch) { + case '-': *sp++ = ch; sp1++; spe++; + case '+': + if (!w) goto zero; + --w; + GET(ch); + } + while(ch == ' ') { +blankdrop: + if (!w--) goto zero; GET(ch); } + while(ch == '0') + { if (!w--) goto zero; GET(ch); } + if (ch == ' ' && f__cblank) + goto blankdrop; + scale1 = f__scale; + while(isdigit(ch)) { +digloop1: + if (sp < spe) *sp++ = ch; + else ++exp; +digloop1e: + if (!w--) goto done; + GET(ch); + } + if (ch == ' ') { + if (f__cblank) + { ch = '0'; goto digloop1; } + goto digloop1e; + } + if (ch == '.') { + exp += d; + if (!w--) goto done; + GET(ch); + if (sp == sp1) { /* no digits yet */ + while(ch == '0') { +skip01: + --exp; +skip0: + if (!w--) goto done; + GET(ch); + } + if (ch == ' ') { + if (f__cblank) goto skip01; + goto skip0; + } + } + while(isdigit(ch)) { +digloop2: + if (sp < spe) + { *sp++ = ch; --exp; } +digloop2e: + if (!w--) goto done; + GET(ch); + } + if (ch == ' ') { + if (f__cblank) + { ch = '0'; goto digloop2; } + goto digloop2e; + } + } + switch(ch) { + default: + break; + case '-': se = 1; goto signonly; + case '+': se = 0; goto signonly; + case 'e': + case 'E': + case 'd': + case 'D': + if (!w--) + goto bad; + GET(ch); + while(ch == ' ') { + if (!w--) + goto bad; + GET(ch); + } + se = 0; + switch(ch) { + case '-': se = 1; + case '+': +signonly: + if (!w--) + goto bad; + GET(ch); + } + while(ch == ' ') { + if (!w--) + goto bad; + GET(ch); + } + if (!isdigit(ch)) + goto bad; + + e = ch - '0'; + for(;;) { + if (!w--) + { ch = '\n'; break; } + GET(ch); + if (!isdigit(ch)) { + if (ch == ' ') { + if (f__cblank) + ch = '0'; + else continue; + } + else + break; + } + e = 10*e + ch - '0'; + if (e > EXPMAX && sp > sp1) + goto bad; + } + if (se) + exp -= e; + else + exp += e; + scale1 = 0; + } + switch(ch) { + case '\n': + case ',': + break; + default: +bad: + return (errno = 115); + } +done: + if (sp > sp1) { + while(*--sp == '0') + ++exp; + if (exp -= scale1) + sprintf(sp+1, "e%ld", exp); + else + sp[1] = 0; + x = atof(s); + } +zero: + if (len == sizeof(real)) + p->pf = x; + else + p->pd = x; + return(0); + } + + + static int +#ifdef KR_headers +rd_A(p,len) char *p; ftnlen len; +#else +rd_A(char *p, ftnlen len) +#endif +{ int i,ch; + for(i=0;i=len) + { for(i=0;i0;f__cursor--) if((ch=(*f__getn)())<0) return(ch); + if(f__cursor<0) + { if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/ + f__cursor = -f__recpos; /* is this in the standard? */ + if(f__external == 0) { + extern char *f__icptr; + f__icptr += f__cursor; + } + else if(f__curunit && f__curunit->useek) + (void) fseek(f__cf,(long) f__cursor,SEEK_CUR); + else + err(f__elist->cierr,106,"fmt"); + f__recpos += f__cursor; + f__cursor=0; + } + switch(p->op) + { + default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op); + sig_die(f__fmtbuf, 1); + case IM: + case I: ch = rd_I((Uint *)ptr,p->p1,len, 10); + break; + + /* O and OM don't work right for character, double, complex, */ + /* or doublecomplex, and they differ from Fortran 90 in */ + /* showing a minus sign for negative values. */ + + case OM: + case O: ch = rd_I((Uint *)ptr, p->p1, len, 8); + break; + case L: ch = rd_L((ftnint *)ptr,p->p1,len); + break; + case A: ch = rd_A(ptr,len); + break; + case AW: + ch = rd_AW(ptr,p->p1,len); + break; + case E: case EE: + case D: + case G: + case GE: + case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2,len); + break; + + /* Z and ZM assume 8-bit bytes. */ + + case ZM: + case Z: + ch = rd_Z((Uint *)ptr, p->p1, len); + break; + } + if(ch == 0) return(ch); + else if(ch == EOF) return(EOF); + if (f__cf) + clearerr(f__cf); + return(errno); +} +#ifdef KR_headers +rd_ned(p) struct syl *p; +#else +rd_ned(struct syl *p) +#endif +{ + switch(p->op) + { + default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op); + sig_die(f__fmtbuf, 1); + case APOS: + return(rd_POS(*(char **)&p->p2)); + case H: return(rd_H(p->p1,*(char **)&p->p2)); + case SLASH: return((*f__donewrec)()); + case TR: + case X: f__cursor += p->p1; + return(1); + case T: f__cursor=p->p1-f__recpos - 1; + return(1); + case TL: f__cursor -= p->p1; + if(f__cursor < -f__recpos) /* TL1000, 1X */ + f__cursor = -f__recpos; + return(1); + } +} diff --git a/gcc/f/runtime/libI77/rewind.c b/gcc/f/runtime/libI77/rewind.c new file mode 100644 index 000000000000..9ba4b239f328 --- /dev/null +++ b/gcc/f/runtime/libI77/rewind.c @@ -0,0 +1,26 @@ +#include "f2c.h" +#include "fio.h" +#ifdef KR_headers +integer f_rew(a) alist *a; +#else +integer f_rew(alist *a) +#endif +{ + unit *b; + if (f__init & 2) + f__fatal (131, "I/O recursion"); + if(a->aunit>=MXUNIT || a->aunit<0) + err(a->aerr,101,"rewind"); + b = &f__units[a->aunit]; + if(b->ufd == NULL || b->uwrt == 3) + return(0); + if(!b->useek) + err(a->aerr,106,"rewind"); + if(b->uwrt) { + (void) t_runc(a); + b->uwrt = 3; + } + rewind(b->ufd); + b->uend=0; + return(0); +} diff --git a/gcc/f/runtime/libI77/rsfe.c b/gcc/f/runtime/libI77/rsfe.c new file mode 100644 index 000000000000..02a9e6d4680a --- /dev/null +++ b/gcc/f/runtime/libI77/rsfe.c @@ -0,0 +1,80 @@ +/* read sequential formatted external */ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" + +xrd_SL(Void) +{ int ch; + if(!f__curunit->uend) + while((ch=getc(f__cf))!='\n') + if (ch == EOF) { + f__curunit->uend = 1; + break; + } + f__cursor=f__recpos=0; + return(1); +} +x_getc(Void) +{ int ch; + if(f__curunit->uend) return(EOF); + ch = getc(f__cf); + if(ch!=EOF && ch!='\n') + { f__recpos++; + return(ch); + } + if(ch=='\n') + { (void) ungetc(ch,f__cf); + return(ch); + } + if(f__curunit->uend || feof(f__cf)) + { errno=0; + f__curunit->uend=1; + return(-1); + } + return(-1); +} +x_endp(Void) +{ + xrd_SL(); + return f__curunit->uend == 1 ? EOF : 0; +} +x_rev(Void) +{ + (void) xrd_SL(); + return(0); +} +#ifdef KR_headers +integer s_rsfe(a) cilist *a; /* start */ +#else +integer s_rsfe(cilist *a) /* start */ +#endif +{ int n; + if(f__init != 1) f_init(); + f__init = 3; + if(n=c_sfe(a)) return(n); + f__reading=1; + f__sequential=1; + f__formatted=1; + f__external=1; + f__elist=a; + f__cursor=f__recpos=0; + f__scale=0; + f__fmtbuf=a->cifmt; + f__curunit= &f__units[a->ciunit]; + f__cf=f__curunit->ufd; + if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); + f__getn= x_getc; + f__doed= rd_ed; + f__doned= rd_ned; + fmt_bg(); + f__doend=x_endp; + f__donewrec=xrd_SL; + f__dorevert=x_rev; + f__cblank=f__curunit->ublnk; + f__cplus=0; + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,"read start"); + if(f__curunit->uend) + err(f__elist->ciend,(EOF),"read start"); + return(0); +} diff --git a/gcc/f/runtime/libI77/rsli.c b/gcc/f/runtime/libI77/rsli.c new file mode 100644 index 000000000000..baf2ba548736 --- /dev/null +++ b/gcc/f/runtime/libI77/rsli.c @@ -0,0 +1,105 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" +#include "fmt.h" /* for f__doend */ + +extern flag f__lquit; +extern int f__lcount; +extern char *f__icptr; +extern char *f__icend; +extern icilist *f__svic; +extern int f__icnum, f__recpos; + +static int i_getc(Void) +{ + if(f__recpos >= f__svic->icirlen) { + if (f__recpos++ == f__svic->icirlen) + return '\n'; + z_rnew(); + } + f__recpos++; + if(f__icptr >= f__icend) + return EOF; + return(*f__icptr++); + } + + static +#ifdef KR_headers +int i_ungetc(ch, f) int ch; FILE *f; +#else +int i_ungetc(int ch, FILE *f) +#endif +{ + if (--f__recpos == f__svic->icirlen) + return '\n'; + if (f__recpos < -1) + err(f__svic->icierr,110,"recend"); + /* *--icptr == ch, and icptr may point to read-only memory */ + return *--f__icptr /* = ch */; + } + + static void +#ifdef KR_headers +c_lir(a) icilist *a; +#else +c_lir(icilist *a) +#endif +{ + extern int l_eof; + if(f__init != 1) f_init(); + f__init = 3; + f__reading = 1; + f__external = 0; + f__formatted = 1; + f__svic = a; + L_len = a->icirlen; + f__recpos = -1; + f__icnum = f__recpos = 0; + f__cursor = 0; + l_getc = i_getc; + l_ungetc = i_ungetc; + l_eof = 0; + f__icptr = a->iciunit; + f__icend = f__icptr + a->icirlen*a->icirnum; + f__cf = 0; + f__curunit = 0; + f__elist = (cilist *)a; + } + + +#ifdef KR_headers +integer s_rsli(a) icilist *a; +#else +integer s_rsli(icilist *a) +#endif +{ + f__lioproc = l_read; + f__lquit = 0; + f__lcount = 0; + c_lir(a); + f__doend = 0; + return(0); + } + +integer e_rsli(Void) +{ f__init = 1; return 0; } + +#ifdef KR_headers +integer s_rsni(a) icilist *a; +#else +extern int x_rsne(cilist*); + +integer s_rsni(icilist *a) +#endif +{ + extern int nml_read; + integer rv; + cilist ca; + ca.ciend = a->iciend; + ca.cierr = a->icierr; + ca.cifmt = a->icifmt; + c_lir(a); + rv = x_rsne(&ca); + nml_read = 0; + return rv; + } diff --git a/gcc/f/runtime/libI77/rsne.c b/gcc/f/runtime/libI77/rsne.c new file mode 100644 index 000000000000..86bb2164f128 --- /dev/null +++ b/gcc/f/runtime/libI77/rsne.c @@ -0,0 +1,607 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" + +#define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */ +#define MAXDIM 20 /* maximum number of subscripts */ + + struct dimen { + ftnlen extent; + ftnlen curval; + ftnlen delta; + ftnlen stride; + }; + typedef struct dimen dimen; + + struct hashentry { + struct hashentry *next; + char *name; + Vardesc *vd; + }; + typedef struct hashentry hashentry; + + struct hashtab { + struct hashtab *next; + Namelist *nl; + int htsize; + hashentry *tab[1]; + }; + typedef struct hashtab hashtab; + + static hashtab *nl_cache; + static int n_nlcache; + static hashentry **zot; + static int colonseen; + extern ftnlen f__typesize[]; + + extern flag f__lquit; + extern int f__lcount, nml_read; + extern t_getc(Void); + +#ifdef KR_headers + extern char *malloc(), *memset(); + +#ifdef ungetc + static int +un_getc(x,f__cf) int x; FILE *f__cf; +{ return ungetc(x,f__cf); } +#else +#define un_getc ungetc + extern int ungetc(); +#endif + +#else +#undef abs +#undef min +#undef max +#include +#include + +#ifdef ungetc + static int +un_getc(int x, FILE *f__cf) +{ return ungetc(x,f__cf); } +#else +#define un_getc ungetc +extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ +#endif +#endif + + static Vardesc * +#ifdef KR_headers +hash(ht, s) hashtab *ht; register char *s; +#else +hash(hashtab *ht, register char *s) +#endif +{ + register int c, x; + register hashentry *h; + char *s0 = s; + + for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1) + x += c; + for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next) + if (!strcmp(s0, h->name)) + return h->vd; + return 0; + } + + hashtab * +#ifdef KR_headers +mk_hashtab(nl) Namelist *nl; +#else +mk_hashtab(Namelist *nl) +#endif +{ + int nht, nv; + hashtab *ht; + Vardesc *v, **vd, **vde; + hashentry *he; + + hashtab **x, **x0, *y; + for(x = &nl_cache; y = *x; x0 = x, x = &y->next) + if (nl == y->nl) + return y; + if (n_nlcache >= MAX_NL_CACHE) { + /* discard least recently used namelist hash table */ + y = *x0; + free((char *)y->next); + y->next = 0; + } + else + n_nlcache++; + nv = nl->nvars; + if (nv >= 0x4000) + nht = 0x7fff; + else { + for(nht = 1; nht < nv; nht <<= 1); + nht += nht - 1; + } + ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *) + + nv*sizeof(hashentry)); + if (!ht) + return 0; + he = (hashentry *)&ht->tab[nht]; + ht->nl = nl; + ht->htsize = nht; + ht->next = nl_cache; + nl_cache = ht; + memset((char *)ht->tab, 0, nht*sizeof(hashentry *)); + vd = nl->vars; + vde = vd + nv; + while(vd < vde) { + v = *vd++; + if (!hash(ht, v->name)) { + he->next = *zot; + *zot = he; + he->name = v->name; + he->vd = v; + he++; + } + } + return ht; + } + +static char Alpha[256], Alphanum[256]; + + static VOID +nl_init(Void) { + register char *s; + register int c; + + for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; ) + Alpha[c] + = Alphanum[c] + = Alpha[c + 'a' - 'A'] + = Alphanum[c + 'a' - 'A'] + = c; + for(s = "0123456789_"; c = *s++; ) + Alphanum[c] = c; + } + +#define GETC(x) (x=(*l_getc)()) +#define Ungetc(x,y) (*l_ungetc)(x,y) + + static int +#ifdef KR_headers +getname(s, slen) register char *s; int slen; +#else +getname(register char *s, int slen) +#endif +{ + register char *se = s + slen - 1; + register int ch; + + GETC(ch); + if (!(*s++ = Alpha[ch & 0xff])) { + if (ch != EOF) + ch = 115; + errfl(f__elist->cierr, ch, "namelist read"); + } + while(*s = Alphanum[GETC(ch) & 0xff]) + if (s < se) + s++; + if (ch == EOF) + err(f__elist->cierr, EOF, "namelist read"); + if (ch > ' ') + Ungetc(ch,f__cf); + return *s = 0; + } + + static int +#ifdef KR_headers +getnum(chp, val) int *chp; ftnlen *val; +#else +getnum(int *chp, ftnlen *val) +#endif +{ + register int ch, sign; + register ftnlen x; + + while(GETC(ch) <= ' ' && ch >= 0); + if (ch == '-') { + sign = 1; + GETC(ch); + } + else { + sign = 0; + if (ch == '+') + GETC(ch); + } + x = ch - '0'; + if (x < 0 || x > 9) + return 115; + while(GETC(ch) >= '0' && ch <= '9') + x = 10*x + ch - '0'; + while(ch <= ' ' && ch >= 0) + GETC(ch); + if (ch == EOF) + return EOF; + *val = sign ? -x : x; + *chp = ch; + return 0; + } + + static int +#ifdef KR_headers +getdimen(chp, d, delta, extent, x1) + int *chp; dimen *d; ftnlen delta, extent, *x1; +#else +getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1) +#endif +{ + register int k; + ftnlen x2, x3; + + if (k = getnum(chp, x1)) + return k; + x3 = 1; + if (*chp == ':') { + if (k = getnum(chp, &x2)) + return k; + x2 -= *x1; + if (*chp == ':') { + if (k = getnum(chp, &x3)) + return k; + if (!x3) + return 123; + x2 /= x3; + colonseen = 1; + } + if (x2 < 0 || x2 >= extent) + return 123; + d->extent = x2 + 1; + } + else + d->extent = 1; + d->curval = 0; + d->delta = delta; + d->stride = x3; + return 0; + } + +#ifndef No_Namelist_Questions + static Void +#ifdef KR_headers +print_ne(a) cilist *a; +#else +print_ne(cilist *a) +#endif +{ + flag intext = f__external; + int rpsave = f__recpos; + FILE *cfsave = f__cf; + unit *usave = f__curunit; + cilist t; + t = *a; + t.ciunit = 6; + s_wsne(&t); + fflush(f__cf); + f__external = intext; + f__reading = 1; + f__recpos = rpsave; + f__cf = cfsave; + f__curunit = usave; + f__elist = a; + } +#endif + + static char where0[] = "namelist read start "; + +#ifdef KR_headers +x_rsne(a) cilist *a; +#else +x_rsne(cilist *a) +#endif +{ + int ch, got1, k, n, nd, quote, readall; + Namelist *nl; + static char where[] = "namelist read"; + char buf[64]; + hashtab *ht; + Vardesc *v; + dimen *dn, *dn0, *dn1; + ftnlen *dims, *dims1; + ftnlen b, b0, b1, ex, no, no1, nomax, size, span; + ftnint type; + char *vaddr; + long iva, ivae; + dimen dimens[MAXDIM], substr; + + if (!Alpha['a']) + nl_init(); + f__reading=1; + f__formatted=1; + got1 = 0; + top: + for(;;) switch(GETC(ch)) { + case EOF: + eof: + err(a->ciend,(EOF),where0); + case '&': + case '$': + goto have_amp; +#ifndef No_Namelist_Questions + case '?': + print_ne(a); + continue; +#endif + default: + if (ch <= ' ' && ch >= 0) + continue; +#ifndef No_Namelist_Comments + while(GETC(ch) != '\n') + if (ch == EOF) + goto eof; +#else + errfl(a->cierr, 115, where0); +#endif + } + have_amp: + if (ch = getname(buf,(int) sizeof(buf))) + return ch; + nl = (Namelist *)a->cifmt; + if (strcmp(buf, nl->name)) +#ifdef No_Bad_Namelist_Skip + errfl(a->cierr, 118, where0); +#else + { + fprintf(stderr, + "Skipping namelist \"%s\": seeking namelist \"%s\".\n", + buf, nl->name); + fflush(stderr); + for(;;) switch(GETC(ch)) { + case EOF: + err(a->ciend, EOF, where0); + case '/': + case '&': + case '$': + if (f__external) + e_rsle(); + else + z_rnew(); + goto top; + case '"': + case '\'': + quote = ch; + more_quoted: + while(GETC(ch) != quote) + if (ch == EOF) + err(a->ciend, EOF, where0); + if (GETC(ch) == quote) + goto more_quoted; + Ungetc(ch,f__cf); + default: + continue; + } + } +#endif + ht = mk_hashtab(nl); + if (!ht) + errfl(f__elist->cierr, 113, where0); + for(;;) { + for(;;) switch(GETC(ch)) { + case EOF: + if (got1) + return 0; + err(a->ciend, EOF, where0); + case '/': + case '$': + case '&': + return 0; + default: + if (ch <= ' ' && ch >= 0 || ch == ',') + continue; + Ungetc(ch,f__cf); + if (ch = getname(buf,(int) sizeof(buf))) + return ch; + goto havename; + } + havename: + v = hash(ht,buf); + if (!v) + errfl(a->cierr, 119, where); + while(GETC(ch) <= ' ' && ch >= 0); + vaddr = v->addr; + type = v->type; + if (type < 0) { + size = -type; + type = TYCHAR; + } + else + size = f__typesize[type]; + ivae = size; + iva = readall = 0; + if (ch == '(' /*)*/ ) { + dn = dimens; + if (!(dims = v->dims)) { + if (type != TYCHAR) + errfl(a->cierr, 122, where); + if (k = getdimen(&ch, dn, (ftnlen)size, + (ftnlen)size, &b)) + errfl(a->cierr, k, where); + if (ch != ')') + errfl(a->cierr, 115, where); + b1 = dn->extent; + if (--b < 0 || b + b1 > size) + return 124; + iva += b; + size = b1; + while(GETC(ch) <= ' ' && ch >= 0); + goto scalar; + } + nd = (int)dims[0]; + nomax = span = dims[1]; + ivae = iva + size*nomax; + colonseen = 0; + if (k = getdimen(&ch, dn, size, nomax, &b)) + errfl(a->cierr, k, where); + no = dn->extent; + b0 = dims[2]; + dims1 = dims += 3; + ex = 1; + for(n = 1; n++ < nd; dims++) { + if (ch != ',') + errfl(a->cierr, 115, where); + dn1 = dn + 1; + span /= *dims; + if (k = getdimen(&ch, dn1, dn->delta**dims, + span, &b1)) + errfl(a->cierr, k, where); + ex *= *dims; + b += b1*ex; + no *= dn1->extent; + dn = dn1; + } + if (ch != ')') + errfl(a->cierr, 115, where); + readall = 1 - colonseen; + b -= b0; + if (b < 0 || b >= nomax) + errfl(a->cierr, 125, where); + iva += size * b; + dims = dims1; + while(GETC(ch) <= ' ' && ch >= 0); + no1 = 1; + dn0 = dimens; + if (type == TYCHAR && ch == '(' /*)*/) { + if (k = getdimen(&ch, &substr, size, size, &b)) + errfl(a->cierr, k, where); + if (ch != ')') + errfl(a->cierr, 115, where); + b1 = substr.extent; + if (--b < 0 || b + b1 > size) + return 124; + iva += b; + b0 = size; + size = b1; + while(GETC(ch) <= ' ' && ch >= 0); + if (b1 < b0) + goto delta_adj; + } + if (readall) + goto delta_adj; + for(; dn0 < dn; dn0++) { + if (dn0->extent != *dims++ || dn0->stride != 1) + break; + no1 *= dn0->extent; + } + if (dn0 == dimens && dimens[0].stride == 1) { + no1 = dimens[0].extent; + dn0++; + } + delta_adj: + ex = 0; + for(dn1 = dn0; dn1 <= dn; dn1++) + ex += (dn1->extent-1) + * (dn1->delta *= dn1->stride); + for(dn1 = dn; dn1 > dn0; dn1--) { + ex -= (dn1->extent - 1) * dn1->delta; + dn1->delta -= ex; + } + } + else if (dims = v->dims) { + no = no1 = dims[1]; + ivae = iva + no*size; + } + else + scalar: + no = no1 = 1; + if (ch != '=') + errfl(a->cierr, 115, where); + got1 = nml_read = 1; + f__lcount = 0; + readloop: + for(;;) { + if (iva >= ivae || iva < 0) { + f__lquit = 1; + goto mustend; + } + else if (iva + no1*size > ivae) + no1 = (ivae - iva)/size; + f__lquit = 0; + if (k = l_read(&no1, vaddr + iva, size, type)) + return k; + if (f__lquit == 1) + return 0; + if (readall) { + iva += dn0->delta; + if (f__lcount > 0) { + no1 = (ivae - iva)/size; + if (no1 > f__lcount) + no1 = f__lcount; + iva += no1 * dn0->delta; + if (k = l_read(&no1, vaddr + iva, + size, type)) + return k; + } + } + mustend: + GETC(ch); + if (readall) + if (iva >= ivae) + readall = 0; + else for(;;) { + switch(ch) { + case ' ': + case '\t': + case '\n': + GETC(ch); + continue; + } + break; + } + if (ch == '/' || ch == '$' || ch == '&') { + f__lquit = 1; + return 0; + } + else if (f__lquit) { + while(ch <= ' ' && ch >= 0) + GETC(ch); + Ungetc(ch,f__cf); + if (!Alpha[ch & 0xff] && ch >= 0) + errfl(a->cierr, 125, where); + break; + } + Ungetc(ch,f__cf); + if (readall && !Alpha[ch & 0xff]) + goto readloop; + if ((no -= no1) <= 0) + break; + for(dn1 = dn0; dn1 <= dn; dn1++) { + if (++dn1->curval < dn1->extent) { + iva += dn1->delta; + goto readloop; + } + dn1->curval = 0; + } + break; + } + } + } + + integer +#ifdef KR_headers +s_rsne(a) cilist *a; +#else +s_rsne(cilist *a) +#endif +{ + extern int l_eof; + int n; + + f__external=1; + l_eof = 0; + if(n = c_le(a)) + return n; + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr,errno,where0); + l_getc = t_getc; + l_ungetc = un_getc; + f__doend = xrd_SL; + n = x_rsne(a); + nml_read = 0; + if (n) + return n; + return e_rsle(); + } diff --git a/gcc/f/runtime/libI77/sfe.c b/gcc/f/runtime/libI77/sfe.c new file mode 100644 index 000000000000..1bb10d9052dc --- /dev/null +++ b/gcc/f/runtime/libI77/sfe.c @@ -0,0 +1,44 @@ +/* sequential formatted external common routines*/ +#include "f2c.h" +#include "fio.h" + +extern char *f__fmtbuf; + +integer e_rsfe(Void) +{ int n; + f__init = 1; + n=en_fio(); + if (f__cf == stdout) + fflush(stdout); + else if (f__cf == stderr) + fflush(stderr); + f__fmtbuf=NULL; + return(n); +} +#ifdef KR_headers +c_sfe(a) cilist *a; /* check */ +#else +c_sfe(cilist *a) /* check */ +#endif +{ unit *p; + if(a->ciunit >= MXUNIT || a->ciunit<0) + err(a->cierr,101,"startio"); + p = &f__units[a->ciunit]; + if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe"); + if(!p->ufmt) err(a->cierr,102,"sfe"); + return(0); +} +integer e_wsfe(Void) +{ +#ifdef ALWAYS_FLUSH + int n; + f__init = 1; + n = en_fio(); + f__fmtbuf=NULL; + if (!n && fflush(f__cf)) + err(f__elist->cierr, errno, "write end"); + return n; +#else + return(e_rsfe()); +#endif +} diff --git a/gcc/f/runtime/libI77/sue.c b/gcc/f/runtime/libI77/sue.c new file mode 100644 index 000000000000..8f2ea314f306 --- /dev/null +++ b/gcc/f/runtime/libI77/sue.c @@ -0,0 +1,87 @@ +#include "f2c.h" +#include "fio.h" +extern uiolen f__reclen; +long f__recloc; + +#ifdef KR_headers +c_sue(a) cilist *a; +#else +c_sue(cilist *a) +#endif +{ + if(a->ciunit >= MXUNIT || a->ciunit < 0) + err(a->cierr,101,"startio"); + f__external=f__sequential=1; + f__formatted=0; + f__curunit = &f__units[a->ciunit]; + f__elist=a; + if(f__curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit)) + err(a->cierr,114,"sue"); + f__cf=f__curunit->ufd; + if(f__curunit->ufmt) err(a->cierr,103,"sue"); + if(!f__curunit->useek) err(a->cierr,103,"sue"); + return(0); +} +#ifdef KR_headers +integer s_rsue(a) cilist *a; +#else +integer s_rsue(cilist *a) +#endif +{ + int n; + if(f__init != 1) f_init(); + f__init = 3; + f__reading=1; + if(n=c_sue(a)) return(n); + f__recpos=0; + if(f__curunit->uwrt && f__nowreading(f__curunit)) + err(a->cierr, errno, "read start"); + if(fread((char *)&f__reclen,sizeof(uiolen),1,f__cf) + != 1) + { if(feof(f__cf)) + { f__curunit->uend = 1; + err(a->ciend, EOF, "start"); + } + clearerr(f__cf); + err(a->cierr, errno, "start"); + } + return(0); +} +#ifdef KR_headers +integer s_wsue(a) cilist *a; +#else +integer s_wsue(cilist *a) +#endif +{ + int n; + if(f__init != 1) f_init(); + f__init = 3; + if(n=c_sue(a)) return(n); + f__reading=0; + f__reclen=0; + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr, errno, "write start"); + f__recloc=ftell(f__cf); + (void) fseek(f__cf,(long)sizeof(uiolen),SEEK_CUR); + return(0); +} +integer e_wsue(Void) +{ long loc; + f__init = 1; + fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); +#ifdef ALWAYS_FLUSH + if (fflush(f__cf)) + err(f__elist->cierr, errno, "write end"); +#endif + loc=ftell(f__cf); + fseek(f__cf,f__recloc,SEEK_SET); + fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); + fseek(f__cf,loc,SEEK_SET); + return(0); +} +integer e_rsue(Void) +{ + f__init = 1; + (void) fseek(f__cf,(long)(f__reclen-f__recpos+sizeof(uiolen)),SEEK_CUR); + return(0); +} diff --git a/gcc/f/runtime/libI77/typesize.c b/gcc/f/runtime/libI77/typesize.c new file mode 100644 index 000000000000..1cb20ff2863d --- /dev/null +++ b/gcc/f/runtime/libI77/typesize.c @@ -0,0 +1,12 @@ +#include "f2c.h" + +ftnlen f__typesize[] = { 0, 0, sizeof(shortint), sizeof(integer), + sizeof(real), sizeof(doublereal), + sizeof(complex), sizeof(doublecomplex), + sizeof(logical), sizeof(char), + 0, sizeof(integer1), + sizeof(logical1), sizeof(shortlogical), +#ifdef Allow_TYQUAD + sizeof(longint), +#endif + 0}; diff --git a/gcc/f/runtime/libI77/uio.c b/gcc/f/runtime/libI77/uio.c new file mode 100644 index 000000000000..ea733cec06c2 --- /dev/null +++ b/gcc/f/runtime/libI77/uio.c @@ -0,0 +1,69 @@ +#include "f2c.h" +#include "fio.h" +#include +uiolen f__reclen; + +#ifdef KR_headers +do_us(number,ptr,len) ftnint *number; char *ptr; ftnlen len; +#else +do_us(ftnint *number, char *ptr, ftnlen len) +#endif +{ + if(f__reading) + { + f__recpos += (int)(*number * len); + if(f__recpos>f__reclen) + err(f__elist->cierr, 110, "do_us"); + if (fread(ptr,(size_t)len,(size_t)(*number),f__cf) != *number) + err(f__elist->ciend, EOF, "do_us"); + return(0); + } + else + { + f__reclen += *number * len; + (void) fwrite(ptr,(size_t)len,(size_t)(*number),f__cf); + return(0); + } +} +#ifdef KR_headers +integer do_ud(number,ptr,len) ftnint *number; char *ptr; ftnlen len; +#else +integer do_ud(ftnint *number, char *ptr, ftnlen len) +#endif +{ + f__recpos += (int)(*number * len); + if(f__recpos > f__curunit->url && f__curunit->url!=1) + err(f__elist->cierr,110,"do_ud"); + if(f__reading) + { +#ifdef Pad_UDread +#ifdef KR_headers + int i; +#else + size_t i; +#endif + if (!(i = fread(ptr,(size_t)len,(size_t)(*number),f__cf)) + && !(f__recpos - *number*len)) + err(f__elist->cierr,EOF,"do_ud"); + if (i < *number) + memset(ptr + i*len, 0, (*number - i)*len); + return 0; +#else + if(fread(ptr,(size_t)len,(size_t)(*number),f__cf) != *number) + err(f__elist->cierr,EOF,"do_ud"); + else return(0); +#endif + } + (void) fwrite(ptr,(size_t)len,(size_t)(*number),f__cf); + return(0); +} +#ifdef KR_headers +integer do_uio(number,ptr,len) ftnint *number; char *ptr; ftnlen len; +#else +integer do_uio(ftnint *number, char *ptr, ftnlen len) +#endif +{ + if(f__sequential) + return(do_us(number,ptr,len)); + else return(do_ud(number,ptr,len)); +} diff --git a/gcc/f/runtime/libI77/util.c b/gcc/f/runtime/libI77/util.c new file mode 100644 index 000000000000..a24932533c13 --- /dev/null +++ b/gcc/f/runtime/libI77/util.c @@ -0,0 +1,51 @@ +#ifndef NON_UNIX_STDIO +#include +#include +#endif +#include "f2c.h" +#include "fio.h" + + VOID +#ifdef KR_headers +g_char(a,alen,b) char *a,*b; ftnlen alen; +#else +g_char(char *a, ftnlen alen, char *b) +#endif +{ + char *x = a + alen, *y = b + alen; + + for(;; y--) { + if (x <= a) { + *b = 0; + return; + } + if (*--x != ' ') + break; + } + *y-- = 0; + do *y-- = *x; + while(x-- > a); + } + + VOID +#ifdef KR_headers +b_char(a,b,blen) char *a,*b; ftnlen blen; +#else +b_char(char *a, char *b, ftnlen blen) +#endif +{ int i; + for(i=0;i +#endif + +#ifndef KR_headers +#undef abs +#undef min +#undef max +#include +#include +#endif + +#include "fmt.h" +#include "fp.h" + +#ifdef KR_headers +wrt_E(p,w,d,e,len) ufloat *p; ftnlen len; +#else +wrt_E(ufloat *p, int w, int d, int e, ftnlen len) +#endif +{ + char buf[FMAX+EXPMAXDIGS+4], *s, *se; + int d1, delta, e1, i, sign, signspace; + double dd; +#ifdef WANT_LEAD_0 + int insert0 = 0; +#endif +#ifndef VAX + int e0 = e; +#endif + + if(e <= 0) + e = 2; + if(f__scale) { + if(f__scale >= d + 2 || f__scale <= -d) + goto nogood; + } + if(f__scale <= 0) + --d; + if (len == sizeof(real)) + dd = p->pf; + else + dd = p->pd; + if (dd < 0.) { + signspace = sign = 1; + dd = -dd; + } + else { + sign = 0; + signspace = (int)f__cplus; +#ifndef VAX + if (!dd) + dd = 0.; /* avoid -0 */ +#endif + } + delta = w - (2 /* for the . and the d adjustment above */ + + 2 /* for the E+ */ + signspace + d + e); +#ifdef WANT_LEAD_0 + if (f__scale <= 0 && delta > 0) { + delta--; + insert0 = 1; + } + else +#endif + if (delta < 0) { +nogood: + while(--w >= 0) + PUT('*'); + return(0); + } + if (f__scale < 0) + d += f__scale; + if (d > FMAX) { + d1 = d - FMAX; + d = FMAX; + } + else + d1 = 0; + sprintf(buf,"%#.*E", d, dd); +#ifndef VAX + /* check for NaN, Infinity */ + if (!isdigit(buf[0])) { + switch(buf[0]) { + case 'n': + case 'N': + signspace = 0; /* no sign for NaNs */ + } + delta = w - strlen(buf) - signspace; + if (delta < 0) + goto nogood; + while(--delta >= 0) + PUT(' '); + if (signspace) + PUT(sign ? '-' : '+'); + for(s = buf; *s; s++) + PUT(*s); + return 0; + } +#endif + se = buf + d + 3; +#ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */ + if (f__scale != 1 && dd) + sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); +#else + if (dd) + sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); + else + strcpy(se, "+00"); +#endif + s = ++se; + if (e < 2) { + if (*s != '0') + goto nogood; + } +#ifndef VAX + /* accommodate 3 significant digits in exponent */ + if (s[2]) { +#ifdef Pedantic + if (!e0 && !s[3]) + for(s -= 2, e1 = 2; s[0] = s[1]; s++); + + /* Pedantic gives the behavior that Fortran 77 specifies, */ + /* i.e., requires that E be specified for exponent fields */ + /* of more than 3 digits. With Pedantic undefined, we get */ + /* the behavior that Cray displays -- you get a bigger */ + /* exponent field if it fits. */ +#else + if (!e0) { + for(s -= 2, e1 = 2; s[0] = s[1]; s++) +#ifdef CRAY + delta--; + if ((delta += 4) < 0) + goto nogood +#endif + ; + } +#endif + else if (e0 >= 0) + goto shift; + else + e1 = e; + } + else + shift: +#endif + for(s += 2, e1 = 2; *s; ++e1, ++s) + if (e1 >= e) + goto nogood; + while(--delta >= 0) + PUT(' '); + if (signspace) + PUT(sign ? '-' : '+'); + s = buf; + i = f__scale; + if (f__scale <= 0) { +#ifdef WANT_LEAD_0 + if (insert0) + PUT('0'); +#endif + PUT('.'); + for(; i < 0; ++i) + PUT('0'); + PUT(*s); + s += 2; + } + else if (f__scale > 1) { + PUT(*s); + s += 2; + while(--i > 0) + PUT(*s++); + PUT('.'); + } + if (d1) { + se -= 2; + while(s < se) PUT(*s++); + se += 2; + do PUT('0'); while(--d1 > 0); + } + while(s < se) + PUT(*s++); + if (e < 2) + PUT(s[1]); + else { + while(++e1 <= e) + PUT('0'); + while(*s) + PUT(*s++); + } + return 0; + } + +#ifdef KR_headers +wrt_F(p,w,d,len) ufloat *p; ftnlen len; +#else +wrt_F(ufloat *p, int w, int d, ftnlen len) +#endif +{ + int d1, sign, n; + double x; + char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s; + + x= (len==sizeof(real)?p->pf:p->pd); + if (d < MAXFRACDIGS) + d1 = 0; + else { + d1 = d - MAXFRACDIGS; + d = MAXFRACDIGS; + } + if (x < 0.) + { x = -x; sign = 1; } + else { + sign = 0; +#ifndef VAX + if (!x) + x = 0.; +#endif + } + + if (n = f__scale) + if (n > 0) + do x *= 10.; while(--n > 0); + else + do x *= 0.1; while(++n < 0); + +#ifdef USE_STRLEN + sprintf(b = buf, "%#.*f", d, x); + n = strlen(b) + d1; +#else + n = sprintf(b = buf, "%#.*f", d, x) + d1; +#endif + +#ifndef WANT_LEAD_0 + if (buf[0] == '0' && d) + { ++b; --n; } +#endif + if (sign) { + /* check for all zeros */ + for(s = b;;) { + while(*s == '0') s++; + switch(*s) { + case '.': + s++; continue; + case 0: + sign = 0; + } + break; + } + } + if (sign || f__cplus) + ++n; + if (n > w) { +#ifdef WANT_LEAD_0 + if (buf[0] == '0' && --n == w) + ++b; + else +#endif + { + while(--w >= 0) + PUT('*'); + return 0; + } + } + for(w -= n; --w >= 0; ) + PUT(' '); + if (sign) + PUT('-'); + else if (f__cplus) + PUT('+'); + while(n = *b++) + PUT(n); + while(--d1 >= 0) + PUT('0'); + return 0; + } diff --git a/gcc/f/runtime/libI77/wrtfmt.c b/gcc/f/runtime/libI77/wrtfmt.c new file mode 100644 index 000000000000..e14efa858335 --- /dev/null +++ b/gcc/f/runtime/libI77/wrtfmt.c @@ -0,0 +1,385 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" + +extern icilist *f__svic; +extern char *f__icptr; + + static int +mv_cur(Void) /* shouldn't use fseek because it insists on calling fflush */ + /* instead we know too much about stdio */ +{ + int cursor = f__cursor; + f__cursor = 0; + if(f__external == 0) { + if(cursor < 0) { + if(f__hiwater < f__recpos) + f__hiwater = f__recpos; + f__recpos += cursor; + f__icptr += cursor; + if(f__recpos < 0) + err(f__elist->cierr, 110, "left off"); + } + else if(cursor > 0) { + if(f__recpos + cursor >= f__svic->icirlen) + err(f__elist->cierr, 110, "recend"); + if(f__hiwater <= f__recpos) + for(; cursor > 0; cursor--) + (*f__putn)(' '); + else if(f__hiwater <= f__recpos + cursor) { + cursor -= f__hiwater - f__recpos; + f__icptr += f__hiwater - f__recpos; + f__recpos = f__hiwater; + for(; cursor > 0; cursor--) + (*f__putn)(' '); + } + else { + f__icptr += cursor; + f__recpos += cursor; + } + } + return(0); + } + if(cursor > 0) { + if(f__hiwater <= f__recpos) + for(;cursor>0;cursor--) (*f__putn)(' '); + else if(f__hiwater <= f__recpos + cursor) { +#if ! defined (NON_UNIX_STDIO) && ! defined (MISSING_FILE_ELEMS) + if(f__cf->_ptr + f__hiwater - f__recpos < buf_end(f__cf)) + f__cf->_ptr += f__hiwater - f__recpos; + else +#endif + (void) fseek(f__cf, (long) (f__hiwater - f__recpos), SEEK_CUR); + cursor -= f__hiwater - f__recpos; + f__recpos = f__hiwater; + for(; cursor > 0; cursor--) + (*f__putn)(' '); + } + else { +#if ! defined (NON_UNIX_STDIO) && ! defined (MISSING_FILE_ELEMS) + if(f__cf->_ptr + cursor < buf_end(f__cf)) + f__cf->_ptr += cursor; + else +#endif + (void) fseek(f__cf, (long)cursor, SEEK_CUR); + f__recpos += cursor; + } + } + if(cursor<0) + { + if(cursor+f__recpos<0) err(f__elist->cierr,110,"left off"); +#if ! defined (NON_UNIX_STDIO) && ! defined (MISSING_FILE_ELEMS) + if(f__cf->_ptr + cursor >= f__cf->_base) + f__cf->_ptr += cursor; + else +#endif + if(f__curunit && f__curunit->useek) + (void) fseek(f__cf,(long)cursor,SEEK_CUR); + else + err(f__elist->cierr,106,"fmt"); + if(f__hiwater < f__recpos) + f__hiwater = f__recpos; + f__recpos += cursor; + } + return(0); +} + + static int +#ifdef KR_headers +wrt_Z(n,w,minlen,len) Uint *n; int w, minlen; ftnlen len; +#else +wrt_Z(Uint *n, int w, int minlen, ftnlen len) +#endif +{ + register char *s, *se; + register int i, w1; + static int one = 1; + static char hex[] = "0123456789ABCDEF"; + s = (char *)n; + --len; + if (*(char *)&one) { + /* little endian */ + se = s; + s += len; + i = -1; + } + else { + se = s + len; + i = 1; + } + for(;; s += i) + if (s == se || *s) + break; + w1 = (i*(se-s) << 1) + 1; + if (*s & 0xf0) + w1++; + if (w1 > w) + for(i = 0; i < w; i++) + (*f__putn)('*'); + else { + if ((minlen -= w1) > 0) + w1 += minlen; + while(--w >= w1) + (*f__putn)(' '); + while(--minlen >= 0) + (*f__putn)('0'); + if (!(*s & 0xf0)) { + (*f__putn)(hex[*s & 0xf]); + if (s == se) + return 0; + s += i; + } + for(;; s += i) { + (*f__putn)(hex[*s >> 4 & 0xf]); + (*f__putn)(hex[*s & 0xf]); + if (s == se) + break; + } + } + return 0; + } + + static int +#ifdef KR_headers +wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base; +#else +wrt_I(Uint *n, int w, ftnlen len, register int base) +#endif +{ int ndigit,sign,spare,i; + longint x; + char *ans; + if(len==sizeof(integer)) x=n->il; + else if(len == sizeof(char)) x = n->ic; +#ifdef Allow_TYQUAD + else if (len == sizeof(longint)) x = n->ili; +#endif + else x=n->is; + ans=f__icvt(x,&ndigit,&sign, base); + spare=w-ndigit; + if(sign || f__cplus) spare--; + if(spare<0) + for(i=0;iil; + else if(len == sizeof(char)) x = n->ic; +#ifdef Allow_TYQUAD + else if (len == sizeof(longint)) x = n->ili; +#endif + else x=n->is; + ans=f__icvt(x,&ndigit,&sign, base); + if(sign || f__cplus) xsign=1; + else xsign=0; + if(ndigit+xsign>w || m+xsign>w) + { for(i=0;i=m) + spare=w-ndigit-xsign; + else + spare=w-m-xsign; + for(i=0;iil; + else if(sz == sizeof(char)) x = n->ic; + else x=n->is; + for(i=0;i 0) (*f__putn)(*p++); + return(0); +} + static int +#ifdef KR_headers +wrt_AW(p,w,len) char * p; ftnlen len; +#else +wrt_AW(char * p, int w, ftnlen len) +#endif +{ + while(w>len) + { w--; + (*f__putn)(' '); + } + while(w-- > 0) + (*f__putn)(*p++); + return(0); +} + + static int +#ifdef KR_headers +wrt_G(p,w,d,e,len) ufloat *p; ftnlen len; +#else +wrt_G(ufloat *p, int w, int d, int e, ftnlen len) +#endif +{ double up = 1,x; + int i=0,oldscale,n,j; + x = len==sizeof(real)?p->pf:p->pd; + if(x < 0 ) x = -x; + if(x<.1) { + if (x != 0.) + return(wrt_E(p,w,d,e,len)); + i = 1; + goto have_i; + } + for(;i<=d;i++,up*=10) + { if(x>=up) continue; + have_i: + oldscale = f__scale; + f__scale = 0; + if(e==0) n=4; + else n=e+2; + i=wrt_F(p,w-n,d-i,len); + for(j=0;jop) + { + default: + fprintf(stderr,"w_ed, unexpected code: %d\n", p->op); + sig_die(f__fmtbuf, 1); + case I: return(wrt_I((Uint *)ptr,p->p1,len, 10)); + case IM: + return(wrt_IM((Uint *)ptr,p->p1,p->p2,len,10)); + + /* O and OM don't work right for character, double, complex, */ + /* or doublecomplex, and they differ from Fortran 90 in */ + /* showing a minus sign for negative values. */ + + case O: return(wrt_I((Uint *)ptr, p->p1, len, 8)); + case OM: + return(wrt_IM((Uint *)ptr,p->p1,p->p2,len,8)); + case L: return(wrt_L((Uint *)ptr,p->p1, len)); + case A: return(wrt_A(ptr,len)); + case AW: + return(wrt_AW(ptr,p->p1,len)); + case D: + case E: + case EE: + return(wrt_E((ufloat *)ptr,p->p1,p->p2,p->p3,len)); + case G: + case GE: + return(wrt_G((ufloat *)ptr,p->p1,p->p2,p->p3,len)); + case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2,len)); + + /* Z and ZM assume 8-bit bytes. */ + + case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len)); + case ZM: + return(wrt_Z((Uint *)ptr,p->p1,p->p2,len)); + } +} +#ifdef KR_headers +w_ned(p) struct syl *p; +#else +w_ned(struct syl *p) +#endif +{ + switch(p->op) + { + default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op); + sig_die(f__fmtbuf, 1); + case SLASH: + return((*f__donewrec)()); + case T: f__cursor = p->p1-f__recpos - 1; + return(1); + case TL: f__cursor -= p->p1; + if(f__cursor < -f__recpos) /* TL1000, 1X */ + f__cursor = -f__recpos; + return(1); + case TR: + case X: + f__cursor += p->p1; + return(1); + case APOS: + return(wrt_AP(*(char **)&p->p2)); + case H: + return(wrt_H(p->p1,*(char **)&p->p2)); + } +} diff --git a/gcc/f/runtime/libI77/wsfe.c b/gcc/f/runtime/libI77/wsfe.c new file mode 100644 index 000000000000..5adb1a49f08b --- /dev/null +++ b/gcc/f/runtime/libI77/wsfe.c @@ -0,0 +1,85 @@ +/*write sequential formatted external*/ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +extern int f__hiwater; + +#ifdef KR_headers +x_putc(c) +#else +x_putc(int c) +#endif +{ + /* this uses \n as an indicator of record-end */ + if(c == '\n' && f__recpos < f__hiwater) { /* fseek calls fflush, a loss */ +#if ! defined (NON_UNIX_STDIO) && ! defined (MISSING_FILE_ELEMS) + if(f__cf->_ptr + f__hiwater - f__recpos < buf_end(f__cf)) + f__cf->_ptr += f__hiwater - f__recpos; + else +#endif + (void) fseek(f__cf, (long)(f__hiwater - f__recpos), SEEK_CUR); + } +#ifdef OMIT_BLANK_CC + if (!f__recpos++ && c == ' ') + return c; +#else + f__recpos++; +#endif + return putc(c,f__cf); +} +x_wSL(Void) +{ + (*f__putn)('\n'); + f__recpos=0; + f__cursor = 0; + f__hiwater = 0; + return(1); +} +xw_end(Void) +{ + if(f__nonl == 0) + (*f__putn)('\n'); + f__hiwater = f__recpos = f__cursor = 0; + return(0); +} +xw_rev(Void) +{ + if(f__workdone) (*f__putn)('\n'); + f__hiwater = f__recpos = f__cursor = 0; + return(f__workdone=0); +} + +#ifdef KR_headers +integer s_wsfe(a) cilist *a; /*start*/ +#else +integer s_wsfe(cilist *a) /*start*/ +#endif +{ int n; + if(f__init != 1) f_init(); + f__init = 3; + if(n=c_sfe(a)) return(n); + f__reading=0; + f__sequential=1; + f__formatted=1; + f__external=1; + f__elist=a; + f__hiwater = f__cursor=f__recpos=0; + f__nonl = 0; + f__scale=0; + f__fmtbuf=a->cifmt; + f__curunit = &f__units[a->ciunit]; + f__cf=f__curunit->ufd; + if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); + f__putn= x_putc; + f__doed= w_ed; + f__doned= w_ned; + f__doend=xw_end; + f__dorevert=xw_rev; + f__donewrec=x_wSL; + fmt_bg(); + f__cplus=0; + f__cblank=f__curunit->ublnk; + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr,errno,"write start"); + return(0); +} diff --git a/gcc/f/runtime/libI77/wsle.c b/gcc/f/runtime/libI77/wsle.c new file mode 100644 index 000000000000..d13f78f650b6 --- /dev/null +++ b/gcc/f/runtime/libI77/wsle.c @@ -0,0 +1,41 @@ +#include "f2c.h" +#include "fio.h" +#include "fmt.h" +#include "lio.h" + +#ifdef KR_headers +integer s_wsle(a) cilist *a; +#else +integer s_wsle(cilist *a) +#endif +{ + int n; + if(n=c_le(a)) return(n); + f__reading=0; + f__external=1; + f__formatted=1; + f__putn = t_putc; + f__lioproc = l_write; + L_len = LINE; + f__donewrec = x_wSL; + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr, errno, "list output start"); + return(0); + } + +integer e_wsle(Void) +{ + f__init = 1; + t_putc('\n'); + f__recpos=0; +#ifdef ALWAYS_FLUSH + if (fflush(f__cf)) + err(f__elist->cierr, errno, "write end"); +#else + if (f__cf == stdout) + fflush(stdout); + else if (f__cf == stderr) + fflush(stderr); +#endif + return(0); + } diff --git a/gcc/f/runtime/libI77/wsne.c b/gcc/f/runtime/libI77/wsne.c new file mode 100644 index 000000000000..0febd52634fd --- /dev/null +++ b/gcc/f/runtime/libI77/wsne.c @@ -0,0 +1,26 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" + + integer +#ifdef KR_headers +s_wsne(a) cilist *a; +#else +s_wsne(cilist *a) +#endif +{ + int n; + + if(n=c_le(a)) + return(n); + f__reading=0; + f__external=1; + f__formatted=1; + f__putn = t_putc; + L_len = LINE; + f__donewrec = x_wSL; + if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) + err(a->cierr, errno, "namelist output start"); + x_wsne(a); + return e_wsle(); + } diff --git a/gcc/f/runtime/libI77/xwsne.c b/gcc/f/runtime/libI77/xwsne.c new file mode 100644 index 000000000000..71f6f1d5da5a --- /dev/null +++ b/gcc/f/runtime/libI77/xwsne.c @@ -0,0 +1,72 @@ +#include "f2c.h" +#include "fio.h" +#include "lio.h" +#include "fmt.h" + +extern int f__Aquote; + + static VOID +nl_donewrec(Void) +{ + (*f__donewrec)(); + PUT(' '); + } + +#ifdef KR_headers +x_wsne(a) cilist *a; +#else +#include + + VOID +x_wsne(cilist *a) +#endif +{ + Namelist *nl; + char *s; + Vardesc *v, **vd, **vde; + ftnint *number, type; + ftnlen *dims; + ftnlen size; + static ftnint one = 1; + extern ftnlen f__typesize[]; + + nl = (Namelist *)a->cifmt; + PUT('&'); + for(s = nl->name; *s; s++) + PUT(*s); + PUT(' '); + f__Aquote = 1; + vd = nl->vars; + vde = vd + nl->nvars; + while(vd < vde) { + v = *vd++; + s = v->name; +#ifdef No_Extra_Namelist_Newlines + if (f__recpos+strlen(s)+2 >= L_len) +#endif + nl_donewrec(); + while(*s) + PUT(*s++); + PUT(' '); + PUT('='); + number = (dims = v->dims) ? dims + 1 : &one; + type = v->type; + if (type < 0) { + size = -type; + type = TYCHAR; + } + else + size = f__typesize[type]; + l_write(number, v->addr, size, type); + if (vd < vde) { + if (f__recpos+2 >= L_len) + nl_donewrec(); + PUT(','); + PUT(' '); + } + else if (f__recpos+1 >= L_len) + nl_donewrec(); + } + f__Aquote = 0; + PUT('/'); + } diff --git a/gcc/f/runtime/libU77/COPYING.LIB b/gcc/f/runtime/libU77/COPYING.LIB new file mode 100644 index 000000000000..eb685a5ec981 --- /dev/null +++ b/gcc/f/runtime/libU77/COPYING.LIB @@ -0,0 +1,481 @@ + GNU LIBRARY GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1991 Free Software Foundation, Inc. + 675 Mass Ave, Cambridge, MA 02139, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the library GPL. It is + numbered 2 because it goes with version 2 of the ordinary GPL.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Library General Public License, applies to some +specially designated Free Software Foundation software, and to any +other libraries whose authors decide to use it. You can use it for +your libraries, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if +you distribute copies of the library, or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link a program with the library, you must provide +complete object files to the recipients so that they can relink them +with the library, after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + Our method of protecting your rights has two steps: (1) copyright +the library, and (2) offer you this license which gives you legal +permission to copy, distribute and/or modify the library. + + Also, for each distributor's protection, we want to make certain +that everyone understands that there is no warranty for this free +library. If the library is modified by someone else and passed on, we +want its recipients to know that what they have is not the original +version, so that any problems introduced by others will not reflect on +the original authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that companies distributing free +software will individually obtain patent licenses, thus in effect +transforming the program into proprietary software. To prevent this, +we have made it clear that any patent must be licensed for everyone's +free use or not licensed at all. + + Most GNU software, including some libraries, is covered by the ordinary +GNU General Public License, which was designed for utility programs. This +license, the GNU Library General Public License, applies to certain +designated libraries. This license is quite different from the ordinary +one; be sure to read it in full, and don't assume that anything in it is +the same as in the ordinary license. + + The reason we have a separate public license for some libraries is that +they blur the distinction we usually make between modifying or adding to a +program and simply using it. Linking a program with a library, without +changing the library, is in some sense simply using the library, and is +analogous to running a utility program or application program. However, in +a textual and legal sense, the linked executable is a combined work, a +derivative of the original library, and the ordinary General Public License +treats it as such. + + Because of this blurred distinction, using the ordinary General +Public License for libraries did not effectively promote software +sharing, because most developers did not use the libraries. We +concluded that weaker conditions might promote sharing better. + + However, unrestricted linking of non-free programs would deprive the +users of those programs of all benefit from the free status of the +libraries themselves. This Library General Public License is intended to +permit developers of non-free programs to use free libraries, while +preserving your freedom as a user of such programs to change the free +libraries that are incorporated in them. (We have not seen how to achieve +this as regards changes in header files, but we have achieved it as regards +changes in the actual functions of the Library.) The hope is that this +will lead to faster development of free libraries. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, while the latter only +works together with the library. + + Note that it is possible for a library to be covered by the ordinary +General Public License rather than by this special one. + + GNU LIBRARY GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library which +contains a notice placed by the copyright holder or other authorized +party saying it may be distributed under the terms of this Library +General Public License (also called "this License"). Each licensee is +addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also compile or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + c) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + d) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the source code distributed need not include anything that is normally +distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Library General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/gcc/f/runtime/libU77/Makefile.in b/gcc/f/runtime/libU77/Makefile.in new file mode 100644 index 000000000000..2e6846b23dea --- /dev/null +++ b/gcc/f/runtime/libU77/Makefile.in @@ -0,0 +1,155 @@ +# Makefile for GNU F77 compiler runtime, libc interface. +# Copyright (C) 1995-1997 Free Software Foundation, Inc. +# Contributed by Dave Love (d.love@dl.ac.uk). +# +#This file is part of GNU Fortran libU77 library. +# +#This library is free software; you can redistribute it and/or modify +#it under the terms of the GNU Library General Public License as +#published by the Free Software Foundation; either version 2, or (at +#your option) any later version. +# +#GNU Fortran is distributed in the hope that it will be useful, but +#WITHOUT ANY WARRANTY; without even the implied warranty of +#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +#Library General Public License for more details. +# +#You should have received a copy of the GNU General Public License +#along with GNU Fortran; see the file COPYING. If not, write to +#Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +SHELL = /bin/sh + +srcdir = @srcdir@ +VPATH = @srcdir@ + +#### Start of system configuration section. #### + +# The _FOR_TARGET things are appropriate for a cross-make, passed by the +# superior makefile +GCC_FOR_TARGET = @CC@ +CC = $(GCC_FOR_TARGET) +CFLAGS = @CFLAGS@ $(GCC_FLAGS) +CPPFLAGS = @CPPFLAGS@ +DEFS = @DEFS@ +CGFLAGS = -g0 +# f2c.h should already be installed in xgcc's include directory but add that +# to -I anyhow in case not using xgcc. fio.h is in libI77. We need config.h +# from `.'. +ALL_CFLAGS = -I. -I$(srcdir) -I$(srcdir)/../libI77 -I../../../include $(CPPFLAGS) $(DEFS) $(CFLAGS) +AR = @AR@ +AR_FLAGS = rc +RANLIB = @RANLIB@ +RANLIB_TEST = @RANLIB_TEST@ +CROSS = @CROSS@ +G77DIR = ../../../ + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $(CC) -c -DSkip_f2c_Undefs $(ALL_CFLAGS) $(CGFLAGS) $< + +OBJS = VersionU.o gerror_.o perror_.o ierrno_.o itime_.o time_.o \ + unlink_.o fnum_.o getpid_.o getuid_.o getgid_.o kill_.o rand_.o \ + srand_.o irand_.o sleep_.o idate_.o ctime_.o etime_.o \ + dtime_.o isatty_.o ltime_.o fstat_.o stat_.o \ + lstat_.o access_.o link_.o getlog_.o ttynam_.o getcwd_.o symlnk_.o \ + vxttime_.o vxtidate_.o gmtime_.o fdate_.o secnds_.o \ + bes.o dbes.o \ + chdir_.o chmod_.o lnblnk_.o hostnm_.o rename_.o fgetc_.o fputc_.o \ + umask_.o system_clock_.o date_.o second_.o flush1_.o mclock_.o \ + alarm_.o +SRCS = Version.c gerror_.c perror_.c ierrno_.c itime_.c time_.c \ + unlink_.c fnum_.c getpid_.c getuid_.c getgid_.c kill_.c rand_.c \ + srand_.c irand_.c sleep_.c idate_.c ctime_.c etime_.c \ + dtime_.c isatty_.c ltime_.c fstat_.c stat_.c \ + lstat_.c access_.c link_.c getlog_.c ttynam_.c getcwd_.c symlnk_.c \ + vxttime_.c vxtidate_.c gmtime_.c fdate_.c secnds_.c \ + bes.c dbes.c \ + chdir_.c chmod_.c lnblnk_.c hostnm_.c rename_.c fgetc_.c fputc_.c \ + umask_.c system_clock_.c date_.c second_.c flush1_.c mclock_.c \ + alarm_.c + +F2C_H = ../../../include/f2c.h + +all: $(OBJS) + +VersionU.o: Version.c + $(CC) -c $(CGFLAGS) -o $@ $(srcdir)/Version.c + +lint: + lint $(CFLAGS) $(SRCS) + +mostlyclean: + -rm -f $(OBJS) + +clean: mostlyclean + -rm -f config.log a.out + +distclean realclean maintainer-clean: clean + -rm -f config.h Makefile config.status config.cache stage? include + +$(OBJS): $(F2C_H) config.h + +check: + -$(G77DIR)g77 --driver=$(G77DIR)/xgcc -B$(G77DIR) -g $(srcdir)/u77-test.f $(lib) && ./a.out + rm -f a.out + +access_.o: access_.c +ctime_.o: ctime_.c +dtime_.o: dtime_.c +etime_.o: etime_.c +fnum_.o: fnum_.c $(srcdir)/../libI77/fio.h +fstat_.o: fstat_.c +gerror_.o: gerror_.c +getcwd_.o: getcwd_.c +getgid_.o: getgid_.c +getlog_.o: getlog_.c +getpid_.o: getpid_.c +getuid_.o: getuid_.c +idate_.o: idate_.c +ierrno_.o: ierrno_.c +irand_.o: irand_.c +isatty_.o: isatty_.c $(srcdir)/../libI77/fio.h +itime_.o: itime_.c +kill_.o: kill_.c +link_.o: link_.c +loc_.o: loc_.c +lstat_.o: lstat_.c +ltime_.o: ltime_.c +perror_.o: perror_.c +qsort.o: qsort.c +qsort_.o: qsort_.c +rand_.o: rand_.c +rename_.o: rename_.c +second_.o: second_.c +sleep_.o: sleep_.c +srand_.o: srand_.c +stat_.o: stat_.c +symlnk_.o: symlnk_.c +time_.o: time_.c +ttynam_.o: ttynam_.c +unlink_.o: unlink_.c +wait_.o: wait_.c +vxttime_.o: vxttime_.c +vtxidate_.o: vxtidate_.c +fdate_.o: fdate_.c +gmtime_.o: gmtime_.c +secnds_.o: secnds_.c +bes.o: bes.c +dbes.o: dbes.c +lnblnk_.o: lnblnk_.c +chmod_.o: chmod_.c +chdir_.o: chdir_.c +hostnm_.o: hostnm_.c +rename_.o: rename_.c +fputc_.o: fputc_.c +fgetc_.o: fgetc_.c +system_clock_.o: system_clock_.c +umask_.o: umask_.c +flush1_.o: flush1_.c +mclock_.o: mclock_.c +alarm_.o: alarm_.c + +.PHONY: mostlyclean clean distclean maintainer-clean lint check all diff --git a/gcc/f/runtime/libU77/PROJECTS b/gcc/f/runtime/libU77/PROJECTS new file mode 100644 index 000000000000..0cf1383cbf97 --- /dev/null +++ b/gcc/f/runtime/libU77/PROJECTS @@ -0,0 +1,10 @@ + -*- indented-text-*- + +* Interface to strget + +* Non-blocking (`asynchronous') i/o (per c.l.f. discussion) + +* `ioinit'-type routine for various i/o options + +* IEEE/VAX/... number format conversion (or XDR interface). This + might be made optionally transparent per logical unit a la DECtran. diff --git a/gcc/f/runtime/libU77/README b/gcc/f/runtime/libU77/README new file mode 100644 index 000000000000..9033a495f1be --- /dev/null +++ b/gcc/f/runtime/libU77/README @@ -0,0 +1,40 @@ +19970811 -*-text-*- + +g77 libU77 +---------- + +This directory contains an implementation of most of the `traditional' +Unix libU77 routines, mostly an interface to libc and libm routines +and some extra ones for time and date etc. It's intended for use with +g77, to whose configuration procedure it's currently tied, but should +be compatible with f2c otherwise, if using the same f2c.h. + +The contents of libU77 and its interfaces aren't consistent across +implementations. This one is mostly taken from documentation for (an +old version of) the Convex implementation and the v2 SunPro one. +As of g77 version 0.5.20, most of these routines have been made +into g77 intrinsics. Some routines have a version with a name prefixed +by `vxt', corresponding to the VMS Fortran versions, and these should +be integrated with g77's intrinsics visibility control. + +A few routines are currently missing; in the case of `fork', for +instance, because they're probably not useful, and in the case of +`qsort' and those for stream-based i/o handling, because they need +more effort/research. The configuration should weed out those few +which correspond to facilities which may not be present on some Unix +systems, such as symbolic links. It's unclear whether the interfaces +to the native library random number routines should be retained, since +their implementation is likely to be something one should avoid +assiduously. + +This library has been tested it under SunOS4.1.3 and Irix5.2 and there +has been some feedback from Linux; presumably potential problems lie +mainly with systems with impoverished native C library support which +haven't been properly taken care of with autoconf. + +There's another GPL'd implementation of this stuff which I only found +out about recently (despite having looked) and I haven't yet checked +how they should be amalgamated. + +Dave Love Aug '95 +(minor changes by Craig Burley Aug '97) diff --git a/gcc/f/runtime/libU77/Version.c b/gcc/f/runtime/libU77/Version.c new file mode 100644 index 000000000000..3251491815d5 --- /dev/null +++ b/gcc/f/runtime/libU77/Version.c @@ -0,0 +1,12 @@ +static char junk[] = "\n@(#) LIBU77 VERSION 19970609\n"; + +char __G77_LIBU77_VERSION__[] = "0.5.21-19970811"; + +#include + +void +g77__uvers__ () +{ + fprintf (stderr, "__G77_LIBU77_VERSION__: %s", __G77_LIBU77_VERSION__); + fputs (junk, stderr); +} diff --git a/gcc/f/runtime/libU77/access_.c b/gcc/f/runtime/libU77/access_.c new file mode 100644 index 000000000000..1699ef065f2f --- /dev/null +++ b/gcc/f/runtime/libU77/access_.c @@ -0,0 +1,80 @@ +/* Copyright (C) 1995, 1997 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if HAVE_UNISTD_H +# include +#endif +#if HAVE_STDLIB_H +# include +#else +# include /* for NULL */ +#endif + +#include +#include +#include "f2c.h" + +#ifndef R_OK /* for SVR1-2 */ +# define R_OK 4 +#endif +#ifndef W_OK +# define W_OK 2 +#endif +#ifndef X_OK +# define X_OK 1 +#endif +#ifndef F_OK +# define F_OK 0 +#endif + +#ifdef KR_headers +void g_char (); + +integer G77_access_0 (name, mode, Lname, Lmode) + char *name, *mode; + ftnlen Lname, Lmode; +#else +void g_char(const char *a, ftnlen alen, char *b); + +integer G77_access_0 (const char *name, const char *mode, ftnlen Lname, ftnlen Lmode) +#endif +{ + char *buff; + char *bp, *blast; + int amode, i; + + buff = malloc (Lname+1); + if (buff == NULL) return -1; + g_char (name, Lname, buff); + amode = 0; + for (i=0;i +#endif + +#include "f2c.h" + +#ifndef RETSIGTYPE +/* we shouldn't rely on this... */ +#ifdef KR_headers +#define RETSIGTYPE int +#else +#define RETSIGTYPE void +#endif +#endif +typedef RETSIGTYPE (*sig_type)(); + +#ifdef KR_headers +extern sig_type signal(); + +int G77_alarm_0 (seconds, proc) + integer *seconds; + sig_type proc; +#else +#include +typedef int (*sig_proc)(int); + +int G77_alarm_0 (integer *seconds, sig_proc proc) +#endif +{ + int status; + + if (signal(SIGALRM, (sig_type)proc) == SIG_ERR) + status = -1; + else + status = alarm (*seconds); + return status; +} diff --git a/gcc/f/runtime/libU77/bes.c b/gcc/f/runtime/libU77/bes.c new file mode 100644 index 000000000000..c5ffdce59a36 --- /dev/null +++ b/gcc/f/runtime/libU77/bes.c @@ -0,0 +1,46 @@ +/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#if 0 /* Don't include these unless necessary -- jcb. */ +#include "f2c.h" +#include + +doublereal G77_besj0_0 (const real *x) { + return j0 (*x); +} + +doublereal G77_besj1_0 (const real *x) { + return j1 (*x); +} + +doublereal G77_besjn_0 (const integer *n, real *x) { + return jn (*n, *x); + } + +doublereal G77_besy0_0 (const real *x) { + return y0 (*x); +} + +doublereal G77_besy1_0 (const real *x) { + return y1 (*x); +} + +doublereal G77_besyn_0 (const integer *n, real *x) { + return yn (*n, *x); +} +#endif diff --git a/gcc/f/runtime/libU77/chdir_.c b/gcc/f/runtime/libU77/chdir_.c new file mode 100644 index 000000000000..500be54fbe6d --- /dev/null +++ b/gcc/f/runtime/libU77/chdir_.c @@ -0,0 +1,57 @@ +/* Copyright (C) 1995, 1997 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if HAVE_UNISTD_H +# include +#endif +#if HAVE_STDLIB_H +# include +#else +# include +#endif + +#include +#include "f2c.h" + + +#ifdef KR_headers +void g_char (); + +integer G77_chdir_0 (name, Lname) + char *name; + ftnlen Lname; +#else +void g_char(const char *a, ftnlen alen, char *b); + +integer G77_chdir_0 (const char *name, const ftnlen Lname) +#endif +{ + char *buff; + char *bp, *blast; + int i; + + buff = malloc (Lname+1); + if (buff == NULL) return -1; + g_char (name, Lname, buff); + i = chdir (buff); + free (buff); + return i ? errno : 0; +} diff --git a/gcc/f/runtime/libU77/chmod_.c b/gcc/f/runtime/libU77/chmod_.c new file mode 100644 index 000000000000..9797b80f3f5f --- /dev/null +++ b/gcc/f/runtime/libU77/chmod_.c @@ -0,0 +1,79 @@ +/* Copyright (C) 1995, 1997 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +/* This definitely shouldn't be done this way -- should canibalise + chmod(1) from GNU or BSD. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if HAVE_UNISTD_H +# include +#endif +#if HAVE_STDLIB_H +# include +#else +# include /* for NULL */ +#endif + +#include "f2c.h" + +#ifndef CHMOD_PATH +#define CHMOD_PATH "/bin/chmod" +#endif + +#ifdef KR_headers +extern void s_cat (); +void g_char (); + +integer G77_chmod_0 (name, mode, Lname, Lmode) + char *name, *mode; + ftnlen Lname, Lmode; +#else +extern void s_cat(char *lp, char *rpp[], ftnlen rnp[], ftnlen *np, ftnlen ll); +void g_char(const char *a, ftnlen alen, char *b); + +integer G77_chmod_0 (/* const */ char *name, /* const */ char *mode, const ftnlen Lname, const ftnlen Lmode) +#endif +{ + char *buff; + char *bp, *blast; + int i; + ftnlen l, l2; + ftnlen six = 6; + address a[6]; + ftnlen ii[6]; + char chmod_path [] = CHMOD_PATH; + l = strlen (chmod_path); + buff = malloc (Lname+Lmode+l+3+13+1); + if (buff == NULL) return -1; + ii[0] = l; a[0] = chmod_path; + ii[1] = 1; a[1] = " "; + ii[2] = Lmode; a[2] = mode; + ii[3] = 2; a[3] = " '"; + for (l2=Lname; (l2 > 1) && (name[l2-1] == ' '); ) + l2--; + ii[4] = l2; a[4] = name; + ii[5] = 13; a[5] = "' 2>/dev/null"; + s_cat (buff, a, ii, &six, Lname+Lmode+l+3+13); + buff[Lname+Lmode+l+3+13] = '\0'; + i = system (buff); + free (buff); + return i; +} diff --git a/gcc/f/runtime/libU77/config.h.in b/gcc/f/runtime/libU77/config.h.in new file mode 100644 index 000000000000..45ada20e2365 --- /dev/null +++ b/gcc/f/runtime/libU77/config.h.in @@ -0,0 +1,73 @@ +/* config.h.in. Generated automatically from configure.in by autoheader. */ + +/* Define to empty if the keyword does not work. */ +#undef const + +/* Define if your struct stat has st_blksize. */ +#undef HAVE_ST_BLKSIZE + +/* Define if your struct stat has st_blocks. */ +#undef HAVE_ST_BLOCKS + +/* Define if your struct stat has st_rdev. */ +#undef HAVE_ST_RDEV + +/* Define to `int' if doesn't define. */ +#undef mode_t + +/* Define to `int' if doesn't define. */ +#undef pid_t + +/* Define to `unsigned' if doesn't define. */ +#undef size_t + +/* Define if you have the ANSI C header files. */ +#undef STDC_HEADERS + +/* Define if you can safely include both and . */ +#undef TIME_WITH_SYS_TIME + +/* Define if your declares struct tm. */ +#undef TM_IN_SYS_TIME + +/* Define as the path of the `chmod' program. */ +#undef CHMOD_PATH + +/* Define if you have the clock function. */ +#undef HAVE_CLOCK + +/* Define if you have the getcwd function. */ +#undef HAVE_GETCWD + +/* Define if you have the gethostname function. */ +#undef HAVE_GETHOSTNAME + +/* Define if you have the getrusage function. */ +#undef HAVE_GETRUSAGE + +/* Define if you have the getwd function. */ +#undef HAVE_GETWD + +/* Define if you have the lstat function. */ +#undef HAVE_LSTAT + +/* Define if you have the strerror function. */ +#undef HAVE_STRERROR + +/* Define if you have the symlink function. */ +#undef HAVE_SYMLINK + +/* Define if you have the header file. */ +#undef HAVE_LIMITS_H + +/* Define if you have the header file. */ +#undef HAVE_STDLIB_H + +/* Define if you have the header file. */ +#undef HAVE_STRING_H + +/* Define if you have the header file. */ +#undef HAVE_SYS_TIME_H + +/* Define if you have the header file. */ +#undef HAVE_UNISTD_H diff --git a/gcc/f/runtime/libU77/configure b/gcc/f/runtime/libU77/configure new file mode 100755 index 000000000000..63fb0e7844e5 --- /dev/null +++ b/gcc/f/runtime/libU77/configure @@ -0,0 +1,1758 @@ +#! /bin/sh + +# Guess values for system-dependent variables and create Makefiles. +# Generated automatically using autoconf version 2.12 +# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc. +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. + +# Defaults: +ac_help= +ac_default_prefix=/usr/local +# Any additions from configure.in: + +# Initialize some variables set by options. +# The variables have the same names as the options, with +# dashes changed to underlines. +build=NONE +cache_file=./config.cache +exec_prefix=NONE +host=NONE +no_create= +nonopt=NONE +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +target=NONE +verbose= +x_includes=NONE +x_libraries=NONE +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datadir='${prefix}/share' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +libdir='${exec_prefix}/lib' +includedir='${prefix}/include' +oldincludedir='/usr/include' +infodir='${prefix}/info' +mandir='${prefix}/man' + +# Initialize some other variables. +subdirs= +MFLAGS= MAKEFLAGS= +# Maximum number of lines to put in a shell here document. +ac_max_here_lines=12 + +ac_prev= +for ac_option +do + + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval "$ac_prev=\$ac_option" + ac_prev= + continue + fi + + case "$ac_option" in + -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; + *) ac_optarg= ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case "$ac_option" in + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir="$ac_optarg" ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build="$ac_optarg" ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file="$ac_optarg" ;; + + -datadir | --datadir | --datadi | --datad | --data | --dat | --da) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ + | --da=*) + datadir="$ac_optarg" ;; + + -disable-* | --disable-*) + ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + eval "enable_${ac_feature}=no" ;; + + -enable-* | --enable-*) + ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } + fi + ac_feature=`echo $ac_feature| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "enable_${ac_feature}='$ac_optarg'" ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix="$ac_optarg" ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he) + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat << EOF +Usage: configure [options] [host] +Options: [defaults in brackets after descriptions] +Configuration: + --cache-file=FILE cache test results in FILE + --help print this message + --no-create do not create output files + --quiet, --silent do not print \`checking...' messages + --version print the version of autoconf that created configure +Directory and file names: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [same as prefix] + --bindir=DIR user executables in DIR [EPREFIX/bin] + --sbindir=DIR system admin executables in DIR [EPREFIX/sbin] + --libexecdir=DIR program executables in DIR [EPREFIX/libexec] + --datadir=DIR read-only architecture-independent data in DIR + [PREFIX/share] + --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data in DIR + [PREFIX/com] + --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var] + --libdir=DIR object code libraries in DIR [EPREFIX/lib] + --includedir=DIR C header files in DIR [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include] + --infodir=DIR info documentation in DIR [PREFIX/info] + --mandir=DIR man documentation in DIR [PREFIX/man] + --srcdir=DIR find the sources in DIR [configure dir or ..] + --program-prefix=PREFIX prepend PREFIX to installed program names + --program-suffix=SUFFIX append SUFFIX to installed program names + --program-transform-name=PROGRAM + run sed PROGRAM on installed program names +EOF + cat << EOF +Host type: + --build=BUILD configure for building on BUILD [BUILD=HOST] + --host=HOST configure for HOST [guessed] + --target=TARGET configure for TARGET [TARGET=HOST] +Features and packages: + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --x-includes=DIR X include files are in DIR + --x-libraries=DIR X library files are in DIR +EOF + if test -n "$ac_help"; then + echo "--enable and --with options recognized:$ac_help" + fi + exit 0 ;; + + -host | --host | --hos | --ho) + ac_prev=host ;; + -host=* | --host=* | --hos=* | --ho=*) + host="$ac_optarg" ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir="$ac_optarg" ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir="$ac_optarg" ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir="$ac_optarg" ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir="$ac_optarg" ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst \ + | --locals | --local | --loca | --loc | --lo) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* \ + | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) + localstatedir="$ac_optarg" ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir="$ac_optarg" ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir="$ac_optarg" ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix="$ac_optarg" ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix="$ac_optarg" ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix="$ac_optarg" ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name="$ac_optarg" ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir="$ac_optarg" ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir="$ac_optarg" ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site="$ac_optarg" ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir="$ac_optarg" ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir="$ac_optarg" ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target="$ac_optarg" ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers) + echo "configure generated by autoconf version 2.12" + exit 0 ;; + + -with-* | --with-*) + ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + case "$ac_option" in + *=*) ;; + *) ac_optarg=yes ;; + esac + eval "with_${ac_package}='$ac_optarg'" ;; + + -without-* | --without-*) + ac_package=`echo $ac_option|sed -e 's/-*without-//'` + # Reject names that are not valid shell variable names. + if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then + { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } + fi + ac_package=`echo $ac_package| sed 's/-/_/g'` + eval "with_${ac_package}=no" ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes="$ac_optarg" ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries="$ac_optarg" ;; + + -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } + ;; + + *) + if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then + echo "configure: warning: $ac_option: invalid host type" 1>&2 + fi + if test "x$nonopt" != xNONE; then + { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } + fi + nonopt="$ac_option" + ;; + + esac +done + +if test -n "$ac_prev"; then + { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } +fi + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +# File descriptor usage: +# 0 standard input +# 1 file creation +# 2 errors and warnings +# 3 some systems may open it to /dev/tty +# 4 used on the Kubota Titan +# 6 checking for... messages and results +# 5 compiler messages saved in config.log +if test "$silent" = yes; then + exec 6>/dev/null +else + exec 6>&1 +fi +exec 5>./config.log + +echo "\ +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. +" 1>&5 + +# Strip out --no-create and --no-recursion so they do not pile up. +# Also quote any args containing shell metacharacters. +ac_configure_args= +for ac_arg +do + case "$ac_arg" in + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c) ;; + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) + ac_configure_args="$ac_configure_args '$ac_arg'" ;; + *) ac_configure_args="$ac_configure_args $ac_arg" ;; + esac +done + +# NLS nuisances. +# Only set these to C if already set. These must not be set unconditionally +# because not all systems understand e.g. LANG=C (notably SCO). +# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'! +# Non-C LC_CTYPE values break the ctype check. +if test "${LANG+set}" = set; then LANG=C; export LANG; fi +if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi +if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi +if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -rf conftest* confdefs.h +# AIX cpp loses on an empty file, so make sure it contains at least a newline. +echo > confdefs.h + +# A filename unique to this package, relative to the directory that +# configure is in, which we can look for to find out if srcdir is correct. +ac_unique_file=access_.c + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then its parent. + ac_prog=$0 + ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` + test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. + srcdir=$ac_confdir + if test ! -r $srcdir/$ac_unique_file; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r $srcdir/$ac_unique_file; then + if test "$ac_srcdir_defaulted" = yes; then + { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } + else + { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } + fi +fi +srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` + +# Prefer explicitly selected file to automatically selected ones. +if test -z "$CONFIG_SITE"; then + if test "x$prefix" != xNONE; then + CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" + else + CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" + fi +fi +for ac_site_file in $CONFIG_SITE; do + if test -r "$ac_site_file"; then + echo "loading site script $ac_site_file" + . "$ac_site_file" + fi +done + +if test -r "$cache_file"; then + echo "loading cache $cache_file" + . $cache_file +else + echo "creating cache $cache_file" + > $cache_file +fi + +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross + +if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then + # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. + if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then + ac_n= ac_c=' +' ac_t=' ' + else + ac_n=-n ac_c= ac_t= + fi +else + ac_n= ac_c='\c' ac_t= +fi + + + + +# For g77 we'll set CC to point at the built gcc, but this will get it into +# the makefiles +# Extract the first word of "gcc", so it can be a program name with args. +set dummy gcc; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:529: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" + for ac_dir in $PATH; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_CC="gcc" + break + fi + done + IFS="$ac_save_ifs" +fi +fi +CC="$ac_cv_prog_CC" +if test -n "$CC"; then + echo "$ac_t""$CC" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + +if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:558: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" + ac_prog_rejected=no + for ac_dir in $PATH; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + if test "$ac_dir/$ac_word" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + break + fi + done + IFS="$ac_save_ifs" +if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# -gt 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + set dummy "$ac_dir/$ac_word" "$@" + shift + ac_cv_prog_CC="$@" + fi +fi +fi +fi +CC="$ac_cv_prog_CC" +if test -n "$CC"; then + echo "$ac_t""$CC" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + + test -z "$CC" && { echo "configure: error: no acceptable cc found in \$PATH" 1>&2; exit 1; } +fi + +echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 +echo "configure:606: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 + +ac_ext=c +# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. +ac_cpp='$CPP $CPPFLAGS' +ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' +ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' +cross_compiling=$ac_cv_prog_cc_cross + +cat > conftest.$ac_ext <&5; (eval $ac_link) 2>&5; } && test -s conftest; then + ac_cv_prog_cc_works=yes + # If we can't run a trivial program, we are probably using a cross compiler. + if (./conftest; exit) 2>/dev/null; then + ac_cv_prog_cc_cross=no + else + ac_cv_prog_cc_cross=yes + fi +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + ac_cv_prog_cc_works=no +fi +rm -fr conftest* + +echo "$ac_t""$ac_cv_prog_cc_works" 1>&6 +if test $ac_cv_prog_cc_works = no; then + { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } +fi +echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 +echo "configure:640: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 +echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 +cross_compiling=$ac_cv_prog_cc_cross + +echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 +echo "configure:645: checking whether we are using GNU C" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.c <&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then + ac_cv_prog_gcc=yes +else + ac_cv_prog_gcc=no +fi +fi + +echo "$ac_t""$ac_cv_prog_gcc" 1>&6 + +if test $ac_cv_prog_gcc = yes; then + GCC=yes + ac_test_CFLAGS="${CFLAGS+set}" + ac_save_CFLAGS="$CFLAGS" + CFLAGS= + echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 +echo "configure:669: checking whether ${CC-cc} accepts -g" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + echo 'void f(){}' > conftest.c +if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then + ac_cv_prog_cc_g=yes +else + ac_cv_prog_cc_g=no +fi +rm -f conftest* + +fi + +echo "$ac_t""$ac_cv_prog_cc_g" 1>&6 + if test "$ac_test_CFLAGS" = set; then + CFLAGS="$ac_save_CFLAGS" + elif test $ac_cv_prog_cc_g = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-O2" + fi +else + GCC= + test "${CFLAGS+set}" = set || CFLAGS="-g" +fi + +if test "$CROSS";then + ac_cv_c_cross=yes +else + ac_cv_c_cross=no +fi + +# Extract the first word of "chmod", so it can be a program name with args. +set dummy chmod; ac_word=$2 +echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 +echo "configure:705: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_path_ac_cv_prog_chmod'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + case "$ac_cv_prog_chmod" in + /*) + ac_cv_path_ac_cv_prog_chmod="$ac_cv_prog_chmod" # Let the user override the test with a path. + ;; + *) + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" + for ac_dir in $PATH; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_path_ac_cv_prog_chmod="$ac_dir/$ac_word" + break + fi + done + IFS="$ac_save_ifs" + test -z "$ac_cv_path_ac_cv_prog_chmod" && ac_cv_path_ac_cv_prog_chmod="no" + ;; +esac +fi +ac_cv_prog_chmod="$ac_cv_path_ac_cv_prog_chmod" +if test -n "$ac_cv_prog_chmod"; then + echo "$ac_t""$ac_cv_prog_chmod" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + +if test "$ac_cv_prog_chmod" != no || test "$CROSS"; then + MAYBES=chmod_.o + cat >> confdefs.h <&6 +echo "configure:752: checking for $ac_word" >&5 +if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test -n "$RANLIB"; then + ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. +else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" + for ac_dir in $PATH; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_cv_prog_RANLIB="ranlib" + break + fi + done + IFS="$ac_save_ifs" + test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":" +fi +fi +RANLIB="$ac_cv_prog_RANLIB" +if test -n "$RANLIB"; then + echo "$ac_t""$RANLIB" 1>&6 +else + echo "$ac_t""no" 1>&6 +fi + + AR=ar + RANLIB_TEST=true +fi + + + +echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 +echo "configure:785: checking how to run the C preprocessor" >&5 +# On Suns, sometimes $CPP names a directory. +if test -n "$CPP" && test -d "$CPP"; then + CPP= +fi +if test -z "$CPP"; then +if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + # This must be in double quotes, not single quotes, because CPP may get + # substituted into the Makefile and "${CC-cc}" will confuse make. + CPP="${CC-cc} -E" + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. + cat > conftest.$ac_ext < +Syntax Error +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:806: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + : +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + CPP="${CC-cc} -E -traditional-cpp" + cat > conftest.$ac_ext < +Syntax Error +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:823: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + : +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + CPP=/lib/cpp +fi +rm -f conftest* +fi +rm -f conftest* + ac_cv_prog_CPP="$CPP" +fi + CPP="$ac_cv_prog_CPP" +else + ac_cv_prog_CPP="$CPP" +fi +echo "$ac_t""$CPP" 1>&6 + +echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 +echo "configure:846: checking for ANSI C header files" >&5 +if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#include +#include +#include +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:859: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + ac_cv_header_stdc=yes +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + ac_cv_header_stdc=no +fi +rm -f conftest* + +if test $ac_cv_header_stdc = yes; then + # SunOS 4.x string.h does not declare mem*, contrary to ANSI. +cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "memchr" >/dev/null 2>&1; then + : +else + rm -rf conftest* + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. +cat > conftest.$ac_ext < +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "free" >/dev/null 2>&1; then + : +else + rm -rf conftest* + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. +if test "$cross_compiling" = yes; then + : +else + cat > conftest.$ac_ext < +#define ISLOWER(c) ('a' <= (c) && (c) <= 'z') +#define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) +#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) +int main () { int i; for (i = 0; i < 256; i++) +if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2); +exit (0); } + +EOF +if { (eval echo configure:926: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null +then + : +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -fr conftest* + ac_cv_header_stdc=no +fi +rm -fr conftest* +fi + +fi +fi + +echo "$ac_t""$ac_cv_header_stdc" 1>&6 +if test $ac_cv_header_stdc = yes; then + cat >> confdefs.h <<\EOF +#define STDC_HEADERS 1 +EOF + +fi + + +echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6 +echo "configure:951: checking whether time.h and sys/time.h may both be included" >&5 +if eval "test \"`echo '$''{'ac_cv_header_time'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#include +#include +int main() { +struct tm *tp; +; return 0; } +EOF +if { (eval echo configure:965: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + ac_cv_header_time=yes +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + ac_cv_header_time=no +fi +rm -f conftest* +fi + +echo "$ac_t""$ac_cv_header_time" 1>&6 +if test $ac_cv_header_time = yes; then + cat >> confdefs.h <<\EOF +#define TIME_WITH_SYS_TIME 1 +EOF + +fi + +for ac_hdr in limits.h unistd.h sys/time.h string.h stdlib.h +do +ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` +echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 +echo "configure:989: checking for $ac_hdr" >&5 +if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:999: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } +ac_err=`grep -v '^ *+' conftest.out` +if test -z "$ac_err"; then + rm -rf conftest* + eval "ac_cv_header_$ac_safe=yes" +else + echo "$ac_err" >&5 + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_header_$ac_safe=no" +fi +rm -f conftest* +fi +if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then + echo "$ac_t""yes" 1>&6 + ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'` + cat >> confdefs.h <&6 +fi +done + + +echo $ac_n "checking for working const""... $ac_c" 1>&6 +echo "configure:1027: checking for working const" >&5 +if eval "test \"`echo '$''{'ac_cv_c_const'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext <j = 5; +} +{ /* ULTRIX-32 V3.1 (Rev 9) vcc rejects this */ + const int foo = 10; +} + +; return 0; } +EOF +if { (eval echo configure:1081: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + ac_cv_c_const=yes +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + ac_cv_c_const=no +fi +rm -f conftest* +fi + +echo "$ac_t""$ac_cv_c_const" 1>&6 +if test $ac_cv_c_const = no; then + cat >> confdefs.h <<\EOF +#define const +EOF + +fi + +echo $ac_n "checking for size_t""... $ac_c" 1>&6 +echo "configure:1102: checking for size_t" >&5 +if eval "test \"`echo '$''{'ac_cv_type_size_t'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#if STDC_HEADERS +#include +#include +#endif +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "size_t[^a-zA-Z_0-9]" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_type_size_t=yes +else + rm -rf conftest* + ac_cv_type_size_t=no +fi +rm -f conftest* + +fi +echo "$ac_t""$ac_cv_type_size_t" 1>&6 +if test $ac_cv_type_size_t = no; then + cat >> confdefs.h <<\EOF +#define size_t unsigned +EOF + +fi + +echo $ac_n "checking for mode_t""... $ac_c" 1>&6 +echo "configure:1135: checking for mode_t" >&5 +if eval "test \"`echo '$''{'ac_cv_type_mode_t'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#if STDC_HEADERS +#include +#include +#endif +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "mode_t[^a-zA-Z_0-9]" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_type_mode_t=yes +else + rm -rf conftest* + ac_cv_type_mode_t=no +fi +rm -f conftest* + +fi +echo "$ac_t""$ac_cv_type_mode_t" 1>&6 +if test $ac_cv_type_mode_t = no; then + cat >> confdefs.h <<\EOF +#define mode_t int +EOF + +fi + + +echo $ac_n "checking for pid_t""... $ac_c" 1>&6 +echo "configure:1169: checking for pid_t" >&5 +if eval "test \"`echo '$''{'ac_cv_type_pid_t'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#if STDC_HEADERS +#include +#include +#endif +EOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + egrep "pid_t[^a-zA-Z_0-9]" >/dev/null 2>&1; then + rm -rf conftest* + ac_cv_type_pid_t=yes +else + rm -rf conftest* + ac_cv_type_pid_t=no +fi +rm -f conftest* + +fi +echo "$ac_t""$ac_cv_type_pid_t" 1>&6 +if test $ac_cv_type_pid_t = no; then + cat >> confdefs.h <<\EOF +#define pid_t int +EOF + +fi + +echo $ac_n "checking for st_blksize in struct stat""... $ac_c" 1>&6 +echo "configure:1202: checking for st_blksize in struct stat" >&5 +if eval "test \"`echo '$''{'ac_cv_struct_st_blksize'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#include +int main() { +struct stat s; s.st_blksize; +; return 0; } +EOF +if { (eval echo configure:1215: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + ac_cv_struct_st_blksize=yes +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + ac_cv_struct_st_blksize=no +fi +rm -f conftest* +fi + +echo "$ac_t""$ac_cv_struct_st_blksize" 1>&6 +if test $ac_cv_struct_st_blksize = yes; then + cat >> confdefs.h <<\EOF +#define HAVE_ST_BLKSIZE 1 +EOF + +fi + +echo $ac_n "checking for st_blocks in struct stat""... $ac_c" 1>&6 +echo "configure:1236: checking for st_blocks in struct stat" >&5 +if eval "test \"`echo '$''{'ac_cv_struct_st_blocks'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#include +int main() { +struct stat s; s.st_blocks; +; return 0; } +EOF +if { (eval echo configure:1249: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + ac_cv_struct_st_blocks=yes +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + ac_cv_struct_st_blocks=no +fi +rm -f conftest* +fi + +echo "$ac_t""$ac_cv_struct_st_blocks" 1>&6 +if test $ac_cv_struct_st_blocks = yes; then + cat >> confdefs.h <<\EOF +#define HAVE_ST_BLOCKS 1 +EOF + +else + LIBOBJS="$LIBOBJS fileblocks.o" +fi + +echo $ac_n "checking for st_rdev in struct stat""... $ac_c" 1>&6 +echo "configure:1272: checking for st_rdev in struct stat" >&5 +if eval "test \"`echo '$''{'ac_cv_struct_st_rdev'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#include +int main() { +struct stat s; s.st_rdev; +; return 0; } +EOF +if { (eval echo configure:1285: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + ac_cv_struct_st_rdev=yes +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + ac_cv_struct_st_rdev=no +fi +rm -f conftest* +fi + +echo "$ac_t""$ac_cv_struct_st_rdev" 1>&6 +if test $ac_cv_struct_st_rdev = yes; then + cat >> confdefs.h <<\EOF +#define HAVE_ST_RDEV 1 +EOF + +fi + +echo $ac_n "checking whether struct tm is in sys/time.h or time.h""... $ac_c" 1>&6 +echo "configure:1306: checking whether struct tm is in sys/time.h or time.h" >&5 +if eval "test \"`echo '$''{'ac_cv_struct_tm'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +#include +int main() { +struct tm *tp; tp->tm_sec; +; return 0; } +EOF +if { (eval echo configure:1319: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + ac_cv_struct_tm=time.h +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + ac_cv_struct_tm=sys/time.h +fi +rm -f conftest* +fi + +echo "$ac_t""$ac_cv_struct_tm" 1>&6 +if test $ac_cv_struct_tm = sys/time.h; then + cat >> confdefs.h <<\EOF +#define TM_IN_SYS_TIME 1 +EOF + +fi + + + +for ac_func in symlink getcwd getwd lstat gethostname strerror clock getrusage +do +echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 +echo "configure:1344: checking for $ac_func" >&5 +if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + cat > conftest.$ac_ext < +/* Override any gcc2 internal prototype to avoid an error. */ +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func(); + +int main() { + +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +$ac_func(); +#endif + +; return 0; } +EOF +if { (eval echo configure:1372: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then + rm -rf conftest* + eval "ac_cv_func_$ac_func=yes" +else + echo "configure: failed program was:" >&5 + cat conftest.$ac_ext >&5 + rm -rf conftest* + eval "ac_cv_func_$ac_func=no" +fi +rm -f conftest* +fi + +if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then + echo "$ac_t""yes" 1>&6 + ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'` + cat >> confdefs.h <&6 +fi +done + +test $ac_cv_func_symlink = yes && MAYBES="$MAYBES symlnk_.o" +test $ac_cv_func_lstat = yes && MAYBES="$MAYBES lstat_.o" +test $ac_cv_func_gethostname = yes && MAYBES="$MAYBES hostnm_.o" +test $ac_cv_func_clock = yes && MAYBES="$MAYBES mclock_.o" + + + + + + + +trap '' 1 2 15 +cat > confcache <<\EOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs. It is not useful on other systems. +# If it contains results you don't want to keep, you may remove or edit it. +# +# By default, configure uses ./config.cache as the cache file, +# creating it if it does not exist already. You can give configure +# the --cache-file=FILE option to use a different cache file; that is +# what configure does when it calls configure scripts in +# subdirectories, so they share the cache. +# Giving --cache-file=/dev/null disables caching, for debugging configure. +# config.status only pays attention to the cache file if you give it the +# --recheck option to rerun configure. +# +EOF +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, don't put newlines in cache variables' values. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +(set) 2>&1 | + case `(ac_space=' '; set) 2>&1` in + *ac_space=\ *) + # `set' does not quote correctly, so add quotes (double-quote substitution + # turns \\\\ into \\, and sed turns \\ into \). + sed -n \ + -e "s/'/'\\\\''/g" \ + -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p" + ;; + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p' + ;; + esac >> confcache +if cmp -s $cache_file confcache; then + : +else + if test -w $cache_file; then + echo "updating cache $cache_file" + cat confcache > $cache_file + else + echo "not updating unwritable cache $cache_file" + fi +fi +rm -f confcache + +trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# Any assignment to VPATH causes Sun make to only execute +# the first set of double-colon rules, so remove it if not needed. +# If there is a colon in the path, we need to keep it. +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' +fi + +trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 + +DEFS=-DHAVE_CONFIG_H + +# Without the "./", some shells look in PATH for config.status. +: ${CONFIG_STATUS=./config.status} + +echo creating $CONFIG_STATUS +rm -f $CONFIG_STATUS +cat > $CONFIG_STATUS </dev/null | sed 1q`: +# +# $0 $ac_configure_args +# +# Compiler output produced by configure, useful for debugging +# configure, is in ./config.log if it exists. + +ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" +for ac_option +do + case "\$ac_option" in + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" + exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; + -version | --version | --versio | --versi | --vers | --ver | --ve | --v) + echo "$CONFIG_STATUS generated by autoconf version 2.12" + exit 0 ;; + -help | --help | --hel | --he | --h) + echo "\$ac_cs_usage"; exit 0 ;; + *) echo "\$ac_cs_usage"; exit 1 ;; + esac +done + +ac_given_srcdir=$srcdir + +trap 'rm -fr `echo "Makefile config.h" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 +EOF +cat >> $CONFIG_STATUS < conftest.subs <<\\CEOF +$ac_vpsub +$extrasub +s%@CFLAGS@%$CFLAGS%g +s%@CPPFLAGS@%$CPPFLAGS%g +s%@CXXFLAGS@%$CXXFLAGS%g +s%@DEFS@%$DEFS%g +s%@LDFLAGS@%$LDFLAGS%g +s%@LIBS@%$LIBS%g +s%@exec_prefix@%$exec_prefix%g +s%@prefix@%$prefix%g +s%@program_transform_name@%$program_transform_name%g +s%@bindir@%$bindir%g +s%@sbindir@%$sbindir%g +s%@libexecdir@%$libexecdir%g +s%@datadir@%$datadir%g +s%@sysconfdir@%$sysconfdir%g +s%@sharedstatedir@%$sharedstatedir%g +s%@localstatedir@%$localstatedir%g +s%@libdir@%$libdir%g +s%@includedir@%$includedir%g +s%@oldincludedir@%$oldincludedir%g +s%@infodir@%$infodir%g +s%@mandir@%$mandir%g +s%@CC@%$CC%g +s%@ac_cv_prog_chmod@%$ac_cv_prog_chmod%g +s%@RANLIB@%$RANLIB%g +s%@AR@%$AR%g +s%@CPP@%$CPP%g +s%@LIBOBJS@%$LIBOBJS%g +s%@MAYBES@%$MAYBES%g +s%@CROSS@%$CROSS%g +s%@RANLIB_TEST@%$RANLIB_TEST%g + +CEOF +EOF + +cat >> $CONFIG_STATUS <<\EOF + +# Split the substitutions into bite-sized pieces for seds with +# small command number limits, like on Digital OSF/1 and HP-UX. +ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script. +ac_file=1 # Number of current file. +ac_beg=1 # First line for current file. +ac_end=$ac_max_sed_cmds # Line after last line for current file. +ac_more_lines=: +ac_sed_cmds="" +while $ac_more_lines; do + if test $ac_beg -gt 1; then + sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file + else + sed "${ac_end}q" conftest.subs > conftest.s$ac_file + fi + if test ! -s conftest.s$ac_file; then + ac_more_lines=false + rm -f conftest.s$ac_file + else + if test -z "$ac_sed_cmds"; then + ac_sed_cmds="sed -f conftest.s$ac_file" + else + ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file" + fi + ac_file=`expr $ac_file + 1` + ac_beg=$ac_end + ac_end=`expr $ac_end + $ac_max_sed_cmds` + fi +done +if test -z "$ac_sed_cmds"; then + ac_sed_cmds=cat +fi +EOF + +cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF +for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then + # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". + case "$ac_file" in + *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` + ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; + *) ac_file_in="${ac_file}.in" ;; + esac + + # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories. + + # Remove last slash and all that follows it. Not all systems have dirname. + ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` + if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then + # The file is in a subdirectory. + test ! -d "$ac_dir" && mkdir "$ac_dir" + ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" + # A "../" for each directory in $ac_dir_suffix. + ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` + else + ac_dir_suffix= ac_dots= + fi + + case "$ac_given_srcdir" in + .) srcdir=. + if test -z "$ac_dots"; then top_srcdir=. + else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; + /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; + *) # Relative path. + srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" + top_srcdir="$ac_dots$ac_given_srcdir" ;; + esac + + + echo creating "$ac_file" + rm -f "$ac_file" + configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." + case "$ac_file" in + *Makefile*) ac_comsub="1i\\ +# $configure_input" ;; + *) ac_comsub= ;; + esac + + ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` + sed -e "$ac_comsub +s%@configure_input@%$configure_input%g +s%@srcdir@%$srcdir%g +s%@top_srcdir@%$top_srcdir%g +" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file +fi; done +rm -f conftest.s* + +# These sed commands are passed to sed as "A NAME B NAME C VALUE D", where +# NAME is the cpp macro being defined and VALUE is the value it is being given. +# +# ac_d sets the value in "#define NAME VALUE" lines. +ac_dA='s%^\([ ]*\)#\([ ]*define[ ][ ]*\)' +ac_dB='\([ ][ ]*\)[^ ]*%\1#\2' +ac_dC='\3' +ac_dD='%g' +# ac_u turns "#undef NAME" with trailing blanks into "#define NAME VALUE". +ac_uA='s%^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)' +ac_uB='\([ ]\)%\1#\2define\3' +ac_uC=' ' +ac_uD='\4%g' +# ac_e turns "#undef NAME" without trailing blanks into "#define NAME VALUE". +ac_eA='s%^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)' +ac_eB='$%\1#\2define\3' +ac_eC=' ' +ac_eD='%g' + +if test "${CONFIG_HEADERS+set}" != set; then +EOF +cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF +fi +for ac_file in .. $CONFIG_HEADERS; do if test "x$ac_file" != x..; then + # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". + case "$ac_file" in + *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` + ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; + *) ac_file_in="${ac_file}.in" ;; + esac + + echo creating $ac_file + + rm -f conftest.frag conftest.in conftest.out + ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` + cat $ac_file_inputs > conftest.in + +EOF + +# Transform confdefs.h into a sed script conftest.vals that substitutes +# the proper values into config.h.in to produce config.h. And first: +# Protect against being on the right side of a sed subst in config.status. +# Protect against being in an unquoted here document in config.status. +rm -f conftest.vals +cat > conftest.hdr <<\EOF +s/[\\&%]/\\&/g +s%[\\$`]%\\&%g +s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%${ac_dA}\1${ac_dB}\1${ac_dC}\2${ac_dD}%gp +s%ac_d%ac_u%gp +s%ac_u%ac_e%gp +EOF +sed -n -f conftest.hdr confdefs.h > conftest.vals +rm -f conftest.hdr + +# This sed command replaces #undef with comments. This is necessary, for +# example, in the case of _POSIX_SOURCE, which is predefined and required +# on some systems where configure will not decide to define it. +cat >> conftest.vals <<\EOF +s%^[ ]*#[ ]*undef[ ][ ]*[a-zA-Z_][a-zA-Z_0-9]*%/* & */% +EOF + +# Break up conftest.vals because some shells have a limit on +# the size of here documents, and old seds have small limits too. + +rm -f conftest.tail +while : +do + ac_lines=`grep -c . conftest.vals` + # grep -c gives empty output for an empty file on some AIX systems. + if test -z "$ac_lines" || test "$ac_lines" -eq 0; then break; fi + # Write a limited-size here document to conftest.frag. + echo ' cat > conftest.frag <> $CONFIG_STATUS + sed ${ac_max_here_lines}q conftest.vals >> $CONFIG_STATUS + echo 'CEOF + sed -f conftest.frag conftest.in > conftest.out + rm -f conftest.in + mv conftest.out conftest.in +' >> $CONFIG_STATUS + sed 1,${ac_max_here_lines}d conftest.vals > conftest.tail + rm -f conftest.vals + mv conftest.tail conftest.vals +done +rm -f conftest.vals + +cat >> $CONFIG_STATUS <<\EOF + rm -f conftest.frag conftest.h + echo "/* $ac_file. Generated automatically by configure. */" > conftest.h + cat conftest.in >> conftest.h + rm -f conftest.in + if cmp -s $ac_file conftest.h 2>/dev/null; then + echo "$ac_file is unchanged" + rm -f conftest.h + else + # Remove last slash and all that follows it. Not all systems have dirname. + ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` + if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then + # The file is in a subdirectory. + test ! -d "$ac_dir" && mkdir "$ac_dir" + fi + rm -f $ac_file + mv conftest.h $ac_file + fi +fi; done + +EOF +cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF + +exit 0 +EOF +chmod +x $CONFIG_STATUS +rm -fr confdefs* $ac_clean_files +test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 + diff --git a/gcc/f/runtime/libU77/configure.in b/gcc/f/runtime/libU77/configure.in new file mode 100644 index 000000000000..d50fa118e932 --- /dev/null +++ b/gcc/f/runtime/libU77/configure.in @@ -0,0 +1,111 @@ +# Process this file with autoconf to produce a configure script. +# Copyright (C) 1995 Free Software Foundation, Inc. +# Contributed by Dave Love (d.love@dl.ac.uk). +# +#This file is part of the GNU Fortran libU77 library. +# +#This library is free software; you can redistribute it and/or modify +#it under the terms of the GNU General Public License as published by +#the Free Software Foundation; either version 2, or (at your option) +#any later version. +# +#GNU Fortran is distributed in the hope that it will be useful, +#but WITHOUT ANY WARRANTY; without even the implied warranty of +#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +#GNU Library General Public License for more details. +# +#You should have received a copy of the GNU Library General Public +#License along with GNU Fortran; see the file COPYING. If not, write +#to Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, +#USA. + +AC_INIT(access_.c) +AC_CONFIG_HEADER(config.h) + +dnl Checks for programs. +# For g77 we'll set CC to point at the built gcc, but this will get it into +# the makefiles +AC_PROG_CC +dnl AC_C_CROSS +dnl Gives misleading `(cached)' message from the check. +if test "$CROSS";then + ac_cv_c_cross=yes +else + ac_cv_c_cross=no +fi + +dnl This is only because we (horribly) punt the chmod job to the program at +dnl present. Note that the result of this test could be wrong in the cross +dnl case. +AC_PATH_PROG(ac_cv_prog_chmod, chmod, no) +if test "$ac_cv_prog_chmod" != no || test "$CROSS"; then + MAYBES=chmod_.o + AC_DEFINE_UNQUOTED(CHMOD_PATH,"$ac_cv_prog_chmod") +else + MAYBES="" +fi + +dnl for g77 build maybe use $(RANLIB_FOR_TARGET) always (like wise AR) +if test "$ac_cv_c_cross" = yes; then + RANLIB=$RANLIB_FOR_TARGET + AR=$AR_FOR_TARGET + AC_SUBST(RANLIB) +else + AC_PROG_RANLIB + AR=ar + RANLIB_TEST=true +fi +AC_SUBST(AR) +dnl not needed for g77 +dnl AC_SUBST(AR_FOR_TARGET) +dnl AC_SUBST(RANLIB_FOR_TARGET) +dnl AC_SUBST(RANLIB_TEST_FOR_TARGET) +dnl not needed for g77? +dnl AC_PROG_MAKE_SET + +dnl Checks for libraries. + +dnl Checks for header files. +AC_HEADER_STDC +dnl We could do this if we didn't know we were using gcc +dnl AC_MSG_CHECKING(for prototype-savvy compiler) +dnl AC_CACHE_VAL(ac_cv_sys_proto, +dnl [AC_TRY_LINK(, +dnl dnl looks screwy because TRY_LINK expects a function body +dnl [return 0;} int foo (int * bar) {], +dnl ac_cv_sys_proto=yes, +dnl [ac_cv_sys_proto=no +dnl AC_DEFINE(KR_headers)])]) +dnl AC_MSG_RESULT($ac_cv_sys_proto) + +AC_HEADER_TIME +AC_CHECK_HEADERS(limits.h unistd.h sys/time.h string.h stdlib.h) + +dnl Checks for typedefs, structures, and compiler characteristics. +AC_C_CONST +AC_TYPE_SIZE_T +AC_TYPE_MODE_T + +AC_TYPE_PID_T +dnl The next 3 demand a dummy fileblocks.o (added to LIBOJS). We don't use +dnl LIBOJS, though. +AC_STRUCT_ST_BLKSIZE +AC_STRUCT_ST_BLOCKS +AC_STRUCT_ST_RDEV +AC_STRUCT_TM + +dnl Checks for library functions. + +AC_CHECK_FUNCS(symlink getcwd getwd lstat gethostname strerror clock getrusage) +test $ac_cv_func_symlink = yes && MAYBES="$MAYBES symlnk_.o" +test $ac_cv_func_lstat = yes && MAYBES="$MAYBES lstat_.o" +test $ac_cv_func_gethostname = yes && MAYBES="$MAYBES hostnm_.o" +test $ac_cv_func_clock = yes && MAYBES="$MAYBES mclock_.o" +AC_SUBST(MAYBES) + + +AC_SUBST(CROSS) +AC_SUBST(RANLIB) +AC_SUBST(RANLIB_TEST) + +AC_OUTPUT(Makefile) diff --git a/gcc/f/runtime/libU77/ctime_.c b/gcc/f/runtime/libU77/ctime_.c new file mode 100644 index 000000000000..af5813772af6 --- /dev/null +++ b/gcc/f/runtime/libU77/ctime_.c @@ -0,0 +1,57 @@ +/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if TIME_WITH_SYS_TIME +# include +# include +#else +# if HAVE_SYS_TIME_H +# include +# else +# include +# endif +#endif +#if HAVE_STRING_H +# include +#else +# include +#endif +#include "f2c.h" + +/* may need sys/time.h & long arg for stime (bsd, svr1-3) */ + +#ifdef KR_headers +/* Character */ void G77_ctime_0 (chtime, Lchtime, xstime) + char *chtime; + longint * xstime; + ftnlen Lchtime; +#else +/* Character */ void G77_ctime_0 (char *chtime, const ftnlen Lchtime, longint * xstime) +#endif +{ + int i, l; + int s_copy (); + time_t stime = *xstime; + + /* Allow a length other than 24 for compatibility with what other + systems do, despite it being documented as 24. */ + s_copy (chtime, ctime (&stime), Lchtime, 24); +} diff --git a/gcc/f/runtime/libU77/date_.c b/gcc/f/runtime/libU77/date_.c new file mode 100644 index 000000000000..8426edc4fb07 --- /dev/null +++ b/gcc/f/runtime/libU77/date_.c @@ -0,0 +1,39 @@ +/* date_.f -- translated by f2c (version 19961001). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + +#include "f2c.h" + +/* Table of constant values */ + +static integer c__5 = 5; + +/* Subroutine */ int G77_date_0 (char *buf, ftnlen buf_len) +{ + /* System generated locals */ + address a__1[5]; + integer i__1, i__2[5]; + char ch__1[24]; + + /* Builtin functions */ + /* Subroutine */ int s_copy(), s_cat(); + + /* Local variables */ + static char cbuf[24]; + extern integer G77_time_0 (); + extern /* Character */ VOID G77_ctime_0 (); + + i__1 = G77_time_0 (); + G77_ctime_0 (ch__1, 24L, &i__1); + s_copy(cbuf, ch__1, 24L, 24L); +/* Writing concatenation */ + i__2[0] = 2, a__1[0] = cbuf + 8; + i__2[1] = 1, a__1[1] = "-"; + i__2[2] = 3, a__1[2] = cbuf + 4; + i__2[3] = 1, a__1[3] = "-"; + i__2[4] = 2, a__1[4] = cbuf + 22; + s_cat(buf, a__1, i__2, &c__5, buf_len); + return 0; +} /* date_ */ + diff --git a/gcc/f/runtime/libU77/dbes.c b/gcc/f/runtime/libU77/dbes.c new file mode 100644 index 000000000000..2330b50489b0 --- /dev/null +++ b/gcc/f/runtime/libU77/dbes.c @@ -0,0 +1,46 @@ +/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include "f2c.h" +#include + +#if 0 /* Don't include these unless necessary -- dnp. */ +doublereal G77_dbesj0_0 (const double *x) { + return j0 (*x); +} + +doublereal G77_dbesj1_0 (const double *x) { + return j1 (*x); +} + +doublereal G77_dbesjn_0 (const integer *n, double *x) { + return jn (*n, *x); + } + +doublereal G77_dbesy0_0 (const double *x) { + return y0 (*x); +} + +doublereal G77_dbesy1_0 (const double *x) { + return y1 (*x); +} + +doublereal G77_dbesyn_0 (const integer *n, double *x) { + return yn (*n, *x); +} +#endif diff --git a/gcc/f/runtime/libU77/dtime_.c b/gcc/f/runtime/libU77/dtime_.c new file mode 100644 index 000000000000..e04ada1eca2f --- /dev/null +++ b/gcc/f/runtime/libU77/dtime_.c @@ -0,0 +1,82 @@ +/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if HAVE_UNISTD_H +# include +#endif +#include +#if HAVE_GETRUSAGE +# include +# include +#endif +#include "f2c.h" + +/* For dtime, etime we store the clock tick parameter (clk_tck) the + first time either of them is invoked rather than each time. This + approach probably speeds up each invocation by avoiding a system + call each time, but means that the overhead of the first call is + different to all others. */ +static long clk_tck = 0; + +#ifdef KR_headers +doublereal G77_dtime_0 (tarray) + real tarray[2]; +#else +doublereal G77_dtime_0 (real tarray[2]) +#endif +{ + time_t utime, stime; + static time_t old_utime = 0, old_stime = 0; + /* The getrusage version is only the default for convenience. */ +#ifdef HAVE_GETRUSAGE + struct rusage rbuff; + + if (getrusage (RUSAGE_SELF, &rbuff) != 0) + abort (); + utime = ((float) (rbuff.ru_utime).tv_sec + + (float) (rbuff.ru_utime).tv_usec/1000000.0); + tarray[0] = utime - (float) old_utime; + stime = ((float) (rbuff.ru_stime).tv_sec + + (float) (rbuff.ru_stime).tv_usec/1000000.0); + tarray[1] = stime - old_stime; +#else /* HAVE_GETRUSAGE */ + struct tms buffer; + +/* NeXTStep seems to define _SC_CLK_TCK but not to have sysconf; + fixme: does using _POSIX_VERSION help? */ +# if defined _SC_CLK_TCK && defined _POSIX_VERSION + if (! clk_tck) clk_tck = sysconf(_SC_CLK_TCK); +# elif defined CLOCKS_PER_SECOND + if (! clk_tck) clk_tck = CLOCKS_PER_SECOND; +# elif defined CLK_TCK + if (! clk_tck) clk_tck = CLK_TCK; +# elif defined HAVE_GETRUSAGE +# else + #error Dont know clock tick length +# endif + if (times(&buffer) < 0) return -1.0; + utime = buffer.tms_utime; stime = buffer.tms_stime; + tarray[0] = ((float)(utime - old_utime)) / (float)clk_tck; + tarray[1] = ((float)(stime - old_stime)) / (float)clk_tck; +#endif /* HAVE_GETRUSAGE */ + old_utime = utime; old_stime = stime; + return (tarray[0]+tarray[1]); +} diff --git a/gcc/f/runtime/libU77/etime_.c b/gcc/f/runtime/libU77/etime_.c new file mode 100644 index 000000000000..36e68133a24f --- /dev/null +++ b/gcc/f/runtime/libU77/etime_.c @@ -0,0 +1,78 @@ +/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if HAVE_UNISTD_H +# include +#endif +#include +#include +#include +#if HAVE_GETRUSAGE +# include +# include +#endif +#include "f2c.h" + +/* For dtime, etime we store the clock tick parameter (clk_tck) the + first time either of them is invoked rather than each time. This + approach probably speeds up each invocation by avoiding a system + call each time, but means that the overhead of the first call is + different to all others. */ +static long clk_tck = 0; + +#ifdef KR_headers +doublereal G77_etime_0 (tarray) + real tarray[2]; +#else +doublereal G77_etime_0 (real tarray[2]) +#endif +{ + /* The getrusage version is only the default for convenience. */ +#ifdef HAVE_GETRUSAGE + struct rusage rbuff; + + if (getrusage (RUSAGE_SELF, &rbuff) != 0) + abort (); + tarray[0] = ((float) (rbuff.ru_utime).tv_sec + + (float) (rbuff.ru_utime).tv_usec/1000000.0); + tarray[1] = ((float) (rbuff.ru_stime).tv_sec + + (float) (rbuff.ru_stime).tv_usec/1000000.0); +#else /* HAVE_GETRUSAGE */ + struct tms buffer; + +/* NeXTStep seems to define _SC_CLK_TCK but not to have sysconf; + fixme: does using _POSIX_VERSION help? */ +# if defined _SC_CLK_TCK && defined _POSIX_VERSION + if (! clk_tck) clk_tck = sysconf(_SC_CLK_TCK); +# elif defined CLOCKS_PER_SECOND + if (! clk_tck) clk_tck = CLOCKS_PER_SECOND; +# elif defined CLK_TCK + if (! clk_tck) clk_tck = CLK_TCK; +# elif defined HAVE_GETRUSAGE +# else + #error Dont know clock tick length +# endif + if (times(&buffer) < 0) return -1.0; + tarray[0] = (float) buffer.tms_utime / (float)clk_tck; + tarray[1] = (float) buffer.tms_stime / (float)clk_tck; +#endif /* HAVE_GETRUSAGE */ + return (tarray[0]+tarray[1]); +} diff --git a/gcc/f/runtime/libU77/fdate_.c b/gcc/f/runtime/libU77/fdate_.c new file mode 100644 index 000000000000..afe8b24fc449 --- /dev/null +++ b/gcc/f/runtime/libU77/fdate_.c @@ -0,0 +1,53 @@ +/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include +#if TIME_WITH_SYS_TIME +# include +# include +#else +# if HAVE_SYS_TIME_H +# include +# else +# include +# endif +#endif +#if HAVE_STRING_H +# include +#else +# include +#endif + +#include "f2c.h" + +/* NB. this implementation is for a character*24 function. There's + also a subroutine version. Of course, the calling convention is + essentially the same for both. */ + +/* Character *24 */ void G77_fdate_0 (char *ret_val, ftnlen ret_val_len) +{ + int s_copy (); + time_t tloc; + tloc = time (NULL); + /* Allow a length other than 24 for compatibility with what other + systems do, despite it being documented as 24. */ + s_copy (ret_val, ctime ((time_t *) &tloc), ret_val_len, 24); +} diff --git a/gcc/f/runtime/libU77/fgetc_.c b/gcc/f/runtime/libU77/fgetc_.c new file mode 100644 index 000000000000..49f39830d2c8 --- /dev/null +++ b/gcc/f/runtime/libU77/fgetc_.c @@ -0,0 +1,70 @@ +/* Copyright (C) 1996 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include +#include "f2c.h" +#include "fio.h" + +#ifdef KR_headers +integer G77_fgetc_0 (lunit, c, Lc) + integer *lunit; + ftnlen Lc; /* should be 1 */ + char *c; +#else +integer G77_fgetc_0 (const integer *lunit, char *c, ftnlen Lc) +#endif +{ + int err; + FILE *f = f__units[*lunit].ufd; + + if (*lunit>=MXUNIT || *lunit<0) + return 101; /* bad unit error */ + err = getc (f); + if (err == EOF) { + if (feof (f)) + return -1; + else + return ferror (f); } + else { + if (Lc == 0) + return 0; + + c[0] = err; + while (--Lc) + *++c = ' '; + return 0; } +} + +#ifdef KR_headers +integer G77_fget_0 (c, Lc) + ftnlen Lc; /* should be 1 */ + char *c; +#else +integer G77_fget_0 (char *c, const ftnlen Lc) +#endif +{ + integer five = 5; + + return G77_fgetc_0 (&five, c, Lc); +} diff --git a/gcc/f/runtime/libU77/flush1_.c b/gcc/f/runtime/libU77/flush1_.c new file mode 100644 index 000000000000..451915debaca --- /dev/null +++ b/gcc/f/runtime/libU77/flush1_.c @@ -0,0 +1,46 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include +#include "f2c.h" +#include "fio.h" + +/* This flushes a single unit, c.f. libI77 version. */ + +#ifdef KR_headers +extern integer G77_fnum_0 (); + +/* Subroutine */ int G77_flush1_0 (lunit) + integer *lunit; +#else +extern integer G77_fnum_0 (integer *); + +/* Subroutine */ int G77_flush1_0 (const integer *lunit) +#endif +{ + if (*lunit>=MXUNIT || *lunit<0) + err(1,101,"flush"); + /* f__units is a table of descriptions for the unit numbers (defined + in io.h) with file descriptors rather than streams */ + if (f__units[*lunit].ufd != NULL && f__units[*lunit].uwrt) + fflush(f__units[*lunit].ufd); + return 0; +} diff --git a/gcc/f/runtime/libU77/fnum_.c b/gcc/f/runtime/libU77/fnum_.c new file mode 100644 index 000000000000..0a3ba013e061 --- /dev/null +++ b/gcc/f/runtime/libU77/fnum_.c @@ -0,0 +1,38 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include "f2c.h" +#include "fio.h" + +#ifdef KR_headers +integer G77_fnum_0 (lunit) + integer *lunit; +#else +integer G77_fnum_0 (integer *lunit) +#endif +{ + if (*lunit>=MXUNIT || *lunit<0) + err(1,101,"fnum"); + /* f__units is a table of descriptions for the unit numbers (defined + in io.h). Use file descriptor (ufd) and fileno rather than udev + field since udev is unix specific */ + return fileno(f__units[*lunit].ufd); +} diff --git a/gcc/f/runtime/libU77/fputc_.c b/gcc/f/runtime/libU77/fputc_.c new file mode 100644 index 000000000000..5a1109e8d4f6 --- /dev/null +++ b/gcc/f/runtime/libU77/fputc_.c @@ -0,0 +1,65 @@ +/* Copyright (C) 1996 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include +#include "f2c.h" +#include "fio.h" + +#ifdef KR_headers +integer G77_fputc_0 (lunit, c, Lc) + integer *lunit; + ftnlen Lc; /* should be 1 */ + char *c; +#else +integer G77_fputc_0 (const integer *lunit, const char *c, const ftnlen Lc) +#endif +{ + int err; + FILE *f = f__units[*lunit].ufd; + + if (*lunit>=MXUNIT || *lunit<0) + return 101; /* bad unit error */ + err = putc (c[0], f); + if (err == EOF) { + if (feof (f)) + return -1; + else + return ferror (f); + } + else + return 0; +} + +#ifdef KR_headers +integer G77_fput_0 (c, Lc) + ftnlen Lc; /* should be 1 */ + char *c; +#else +integer G77_fput_0 (const char *c, const ftnlen Lc) +#endif +{ + integer six = 6; + + return G77_fputc_0 (&six, c, Lc); +} diff --git a/gcc/f/runtime/libU77/fstat_.c b/gcc/f/runtime/libU77/fstat_.c new file mode 100644 index 000000000000..da5434ad0b73 --- /dev/null +++ b/gcc/f/runtime/libU77/fstat_.c @@ -0,0 +1,71 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include "f2c.h" +#include +#include + +#ifdef KR_headers +extern integer G77_fnum_0 (); + +integer G77_fstat_0 (lunit, statb) + integer *lunit; + integer statb[13]; +#else +extern integer G77_fnum_0 (const integer *); + +integer G77_fstat_0 (const integer *lunit, integer statb[13]) +#endif +{ + int err; + struct stat buf; + + err = fstat (G77_fnum_0 (lunit), &buf); + statb[0] = buf.st_dev; + statb[1] = buf.st_ino; + statb[2] = buf.st_mode; + statb[3] = buf.st_nlink; + statb[4] = buf.st_uid; + statb[5] = buf.st_gid; +#if HAVE_ST_RDEV + statb[6] = buf.st_rdev; /* not posix */ +#else + statb[6] = 0; +#endif + statb[7] = buf.st_size; + statb[8] = buf.st_atime; + statb[9] = buf.st_mtime; + statb[10] = buf.st_ctime; +#if HAVE_ST_BLKSIZE + statb[11] = buf.st_blksize; /* not posix */ +#else + statb[11] = -1; +#endif +#if HAVE_ST_BLOCKS + statb[12] = buf.st_blocks; /* not posix */ +#else + statb[12] = -1; +#endif + return err; +} diff --git a/gcc/f/runtime/libU77/gerror_.c b/gcc/f/runtime/libU77/gerror_.c new file mode 100644 index 000000000000..6f5943c1dcec --- /dev/null +++ b/gcc/f/runtime/libU77/gerror_.c @@ -0,0 +1,49 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include +#include +#if HAVE_STRING_H +# include +#else +# include +#endif +#include "f2c.h" + +#ifndef HAVE_STRERROR + extern char *sys_errlist []; +# define strerror(i) (sys_errlist[i]) +#endif +#ifdef KR_headers +extern void s_copy (); +/* Subroutine */ int G77_gerror_0 (str, Lstr) + char *str; ftnlen Lstr; +#else +extern void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb); +/* Subroutine */ int G77_gerror_0 (char *str, ftnlen Lstr) +#endif +{ + char * s; + + s = strerror(errno); + s_copy (str, s, Lstr, strlen (s)); + return 0; +} diff --git a/gcc/f/runtime/libU77/getcwd_.c b/gcc/f/runtime/libU77/getcwd_.c new file mode 100644 index 000000000000..e01b22c698da --- /dev/null +++ b/gcc/f/runtime/libU77/getcwd_.c @@ -0,0 +1,98 @@ +/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include +#if HAVE_STRING_H +# include +#else +# include +#endif +#include /* for NULL */ +#include "f2c.h" + +#if HAVE_GETCWD + +#ifdef HAVE_UNISTD_H +# include +#else + extern char *getcwd (); +#endif + +#ifdef KR_headers +extern void s_copy (); +integer G77_getcwd_0 (str, Lstr) + char *str; ftnlen Lstr; +#else +extern void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb); +integer G77_getcwd_0 (char *str, const ftnlen Lstr) +#endif +{ + int i; + char *ret; + + ret = getcwd (str, Lstr); + if (ret == NULL) return errno; + for (i=strlen(str); i + extern char *getwd (); +#ifdef KR_headers +extern VOID s_copy (); +integer G77_getcwd_0 (str, Lstr) + char *str; ftnlen Lstr; +#else +extern void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb); +integer G77_getcwd_0 (char *str, const ftnlen Lstr) +#endif +{ + char pathname[MAXPATHLEN]; + size_t l; + + if (getwd (pathname) == NULL) { + return errno; + } else { + s_copy (str, pathname, Lstr, strlen (str)); + return 0; + } +} + +#else /* !HAVE_GETWD && !HAVE_GETCWD */ + +#ifdef KR_headers +extern VOID s_copy (); +integer G77_getcwd_0 (str, Lstr) + char *str; ftnlen Lstr; +#else +extern void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb); +integer G77_getcwd_0 (char *str, const ftnlen Lstr) +#endif +{ + return errno = ENOSYS; +} + +#endif diff --git a/gcc/f/runtime/libU77/getgid_.c b/gcc/f/runtime/libU77/getgid_.c new file mode 100644 index 000000000000..02e8a4e4895b --- /dev/null +++ b/gcc/f/runtime/libU77/getgid_.c @@ -0,0 +1,35 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if HAVE_UNISTD_H +#include +#endif +#include +#include "f2c.h" + +#ifdef KR_headers +integer G77_getgid_0 () +#else +integer G77_getgid_0 (void) +#endif +{ + return getgid (); +} diff --git a/gcc/f/runtime/libU77/getlog_.c b/gcc/f/runtime/libU77/getlog_.c new file mode 100644 index 000000000000..a2c5f20f28b0 --- /dev/null +++ b/gcc/f/runtime/libU77/getlog_.c @@ -0,0 +1,62 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if HAVE_STDLIB_H +# include +#else +# include +#endif +#include +#if HAVE_UNISTD_H +# include +#endif +#if HAVE_STRING_H +# include +#else +# include +#endif +#include "f2c.h" + +/* getlogin not in svr1-3 */ + +/* SGI also has character*(*) function getlog() */ + +#ifdef KR_headers +extern VOID s_copy (); +/* Subroutine */ int G77_getlog_0 (str, Lstr) + char *str; ftnlen Lstr; +#else +extern void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb); +/* Subroutine */ int G77_getlog_0 (char *str, const ftnlen Lstr) +#endif +{ + size_t i; + char *p; + + p = getlogin (); + if (p != NULL) { + i = strlen (p); + s_copy (str, p, Lstr, i); + } else { + s_copy (str, " ", Lstr, 1); + } + return 0; +} diff --git a/gcc/f/runtime/libU77/getpid_.c b/gcc/f/runtime/libU77/getpid_.c new file mode 100644 index 000000000000..fa484785957c --- /dev/null +++ b/gcc/f/runtime/libU77/getpid_.c @@ -0,0 +1,35 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if HAVE_UNISTD_H +#include +#endif +#include +#include "f2c.h" + +#ifdef KR_headers +integer G77_getpid_0 () +#else +integer G77_getpid_0 (void) +#endif +{ + return getpid (); +} diff --git a/gcc/f/runtime/libU77/getuid_.c b/gcc/f/runtime/libU77/getuid_.c new file mode 100644 index 000000000000..421bb4c93627 --- /dev/null +++ b/gcc/f/runtime/libU77/getuid_.c @@ -0,0 +1,35 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if HAVE_UNISTD_H +#include +#endif +#include +#include "f2c.h" + +#ifdef KR_headers +integer G77_getuid_0 () +#else +integer G77_getuid_0 (void) +#endif +{ + return getuid (); +} diff --git a/gcc/f/runtime/libU77/gmtime_.c b/gcc/f/runtime/libU77/gmtime_.c new file mode 100644 index 000000000000..5f6f8ec6a0b3 --- /dev/null +++ b/gcc/f/runtime/libU77/gmtime_.c @@ -0,0 +1,54 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +/* fixme: do we need to use TM_IN_SYS_TIME? */ +#if TIME_WITH_SYS_TIME +# include +# include +#else +# if HAVE_SYS_TIME_H +# include +# else +# include +# endif +#endif +#include "f2c.h" + +#ifdef KR_headers +/* Subroutine */ int G77_gmtime_0 (stime, tarray) + integer *stime, tarray[9]; +#else +/* Subroutine */ int G77_gmtime_0 (const integer * stime, integer tarray[9]) +#endif +{ + struct tm *lt; + lt = gmtime ((time_t *) stime); + tarray[0] = lt->tm_sec; + tarray[1] = lt->tm_min; + tarray[2] = lt->tm_hour; + tarray[3] = lt->tm_mday; + tarray[4] = lt->tm_mon; + tarray[5] = lt->tm_year; + tarray[6] = lt->tm_wday; + tarray[7] = lt->tm_yday; + tarray[8] = lt->tm_isdst; + return 0; +} diff --git a/gcc/f/runtime/libU77/hostnm_.c b/gcc/f/runtime/libU77/hostnm_.c new file mode 100644 index 000000000000..2a7b590a3585 --- /dev/null +++ b/gcc/f/runtime/libU77/hostnm_.c @@ -0,0 +1,48 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if HAVE_STRING_H +# include +#else +# include +#endif +#if HAVE_UNISTD_H +# include +#endif +#include "f2c.h" + +integer G77_hostnm_0 (char *name, ftnlen Lname) +{ + int ret, i; + +#if HAVE_GETHOSTNAME + ret = gethostname (name, Lname); + if (ret==0) { + /* Pad with blanks (assuming gethostname will make an error + return if it can't fit in the null). */ + for (i=strlen(name); i<=Lname; i++) + name[i] = ' '; + } + return ret; +#else + return errno = ENOSYS; +#endif +} diff --git a/gcc/f/runtime/libU77/idate_.c b/gcc/f/runtime/libU77/idate_.c new file mode 100644 index 000000000000..c4075767a4c3 --- /dev/null +++ b/gcc/f/runtime/libU77/idate_.c @@ -0,0 +1,57 @@ +/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include +#if TIME_WITH_SYS_TIME +# include +# include +#else +# if HAVE_SYS_TIME_H +# include +# else +# include +# endif +#endif +#include "f2c.h" + +/* VMS and Irix versions (at least) differ from libU77 elsewhere */ + +/* libU77 one: */ + +#ifdef KR_headers +/* Subroutine */ int G77_idate_0 (iarray) + int iarray[3]; +#else +/* Subroutine */ int G77_idate_0 (int iarray[3]) +#endif +{ + struct tm *lt; + time_t tim; + tim = time(NULL); + lt = localtime(&tim); + iarray[0] = lt->tm_mday; + iarray[1] = lt->tm_mon + 1; /* in range 1-12 in SunOS (experimentally) */ + /* The `+1900' is consistent with SunOS and Irix, but they don't say + it's added. I think I've seen a system where tm_year was since + 1970, but can't now verify that, so assume the ANSI definition. */ + iarray[2] = lt->tm_year + 1900; + return 0; +} diff --git a/gcc/f/runtime/libU77/ierrno_.c b/gcc/f/runtime/libU77/ierrno_.c new file mode 100644 index 000000000000..557b53a46648 --- /dev/null +++ b/gcc/f/runtime/libU77/ierrno_.c @@ -0,0 +1,32 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include +#include "f2c.h" + +#ifdef KR_headers +integer G77_ierrno_0 () +#else +integer G77_ierrno_0 (void) +#endif +{ + return errno; +} diff --git a/gcc/f/runtime/libU77/irand_.c b/gcc/f/runtime/libU77/irand_.c new file mode 100644 index 000000000000..2bf14ccee263 --- /dev/null +++ b/gcc/f/runtime/libU77/irand_.c @@ -0,0 +1,57 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if HAVE_STDLIB_H +# include +#endif +#include "f2c.h" + +/* We could presumably do much better than the traditional libc + version, though at least the glibc one is reasonable, it seems. + For the sake of the innocent, I'm not sure we should really do + this... */ + +/* Note this is per SunOS -- other s may have no arg. */ + +#ifdef KR_headers +integer G77_irand_0 (flag) + integer *flag; +#else +integer G77_irand_0 (integer *flag) +#endif +{ + switch (*flag) { + case 0: + break; + case 1: + srand (0); /* Arbitrary choice of initialiser. */ + break; + default: + srand (*flag); + } + return rand (); +} + + + + + + diff --git a/gcc/f/runtime/libU77/isatty_.c b/gcc/f/runtime/libU77/isatty_.c new file mode 100644 index 000000000000..92c33468f539 --- /dev/null +++ b/gcc/f/runtime/libU77/isatty_.c @@ -0,0 +1,44 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if HAVE_UNISTD_H +# include +#endif +#include "f2c.h" +#include "fio.h" + +#ifdef KR_headers +extern integer G77_fnum_0 (); + +logical G77_isatty_0 (lunit) + integer *lunit; +#else +extern integer G77_fnum_0 (integer *); + +logical G77_isatty_0 (integer *lunit) +#endif +{ + if (*lunit>=MXUNIT || *lunit<0) + err(1,101,"isatty"); + /* f__units is a table of descriptions for the unit numbers (defined + in io.h) with file descriptors rather than streams */ + return (isatty(G77_fnum_0 (lunit)) ? TRUE_ : FALSE_); +} diff --git a/gcc/f/runtime/libU77/itime_.c b/gcc/f/runtime/libU77/itime_.c new file mode 100644 index 000000000000..50378d544262 --- /dev/null +++ b/gcc/f/runtime/libU77/itime_.c @@ -0,0 +1,51 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include +#if TIME_WITH_SYS_TIME +# include +# include +#else +# if HAVE_SYS_TIME_H +# include +# else +# include +# endif +#endif +#include "f2c.h" + +#ifdef KR_headers +/* Subroutine */ int G77_itime_0 (tarray) + integer tarray[3]; +#else +/* Subroutine */ int G77_itime_0 (integer tarray[3]) +#endif +{ + struct tm *lt; + time_t tim; + + tim = time(NULL); + lt = localtime(&tim); + tarray[0] = lt->tm_hour; + tarray[1] = lt->tm_min; + tarray[2] = lt->tm_sec; + return 0; +} diff --git a/gcc/f/runtime/libU77/kill_.c b/gcc/f/runtime/libU77/kill_.c new file mode 100644 index 000000000000..32afddf1e460 --- /dev/null +++ b/gcc/f/runtime/libU77/kill_.c @@ -0,0 +1,37 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include +#include +#include +#include "f2c.h" + +/* fixme: bsd, svr1-3 use int, not pid_t */ + +#ifdef KR_headers +integer G77_kill_0 (pid, signum) + integer *pid, *signum; +#else +integer G77_kill_0 (const integer *pid, const integer *signum) +#endif +{ + return kill ((pid_t) *pid, *signum) ? errno : 0; +} diff --git a/gcc/f/runtime/libU77/link_.c b/gcc/f/runtime/libU77/link_.c new file mode 100644 index 000000000000..6892dcb76949 --- /dev/null +++ b/gcc/f/runtime/libU77/link_.c @@ -0,0 +1,58 @@ +/* Copyright (C) 1995, 1997 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if HAVE_STDLIB_H +# include +#else +# include +#endif +#if HAVE_UNISTD_H +# include +#endif +#include +#include +#include "f2c.h" + +#ifdef KR_headers +void g_char (); + +integer G77_link_0 (path1, path2, Lpath1, Lpath2) + char *path1, *path2; ftnlen Lpath1, Lpath2; +#else +void g_char(const char *a, ftnlen alen, char *b); + +integer G77_link_0 (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2) +#endif +{ + char *buff1, *buff2; + char *bp, *blast; + int i; + + buff1 = malloc (Lpath1+1); + if (buff1 == NULL) return -1; + g_char (path1, Lpath1, buff1); + buff2 = malloc (Lpath2+1); + if (buff2 == NULL) return -1; + g_char (path2, Lpath2, buff2); + i = link (buff1, buff2); + free (buff1); free (buff2); + return i ? errno : 0; +} diff --git a/gcc/f/runtime/libU77/lnblnk_.c b/gcc/f/runtime/libU77/lnblnk_.c new file mode 100644 index 000000000000..806eca293f10 --- /dev/null +++ b/gcc/f/runtime/libU77/lnblnk_.c @@ -0,0 +1,35 @@ +/* Copyright (C) 1995, 1997 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + + +/* via f2c from Fortran */ + +#include "f2c.h" + +integer G77_lnblnk_0 (char *str, ftnlen str_len) +{ + integer ret_val; + integer i_len(); + + for (ret_val = str_len; ret_val >= 1; --ret_val) { + if (*(unsigned char *)&str[ret_val - 1] != ' ') { + return ret_val; + } + } + return ret_val; +} diff --git a/gcc/f/runtime/libU77/lstat_.c b/gcc/f/runtime/libU77/lstat_.c new file mode 100644 index 000000000000..17f0c1a6b3a3 --- /dev/null +++ b/gcc/f/runtime/libU77/lstat_.c @@ -0,0 +1,86 @@ +/* Copyright (C) 1995, 1997 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include +#if HAVE_STDLIB_H +# include +#endif +#include +#include +#include "f2c.h" + +/* lstat isn't posix */ + +#ifdef KR_headers +void g_char(); + +integer G77_lstat_0 (name, statb, Lname) + char *name; + integer statb[13]; + ftnlen Lname; +#else +void g_char(const char *a, ftnlen alen, char *b); + +integer G77_lstat_0 (const char *name, integer statb[13], const ftnlen Lname) +#endif +{ +#if HAVE_LSTAT + char *buff; + char *bp, *blast; + int err; + struct stat buf; + + buff = malloc (Lname+1); + if (buff == NULL) return -1; + g_char (name, Lname, buff); + err = lstat (buff, &buf); + free (buff); + statb[0] = buf.st_dev; + statb[1] = buf.st_ino; + statb[2] = buf.st_mode; + statb[3] = buf.st_nlink; + statb[4] = buf.st_uid; + statb[5] = buf.st_gid; +#if HAVE_ST_RDEV + statb[6] = buf.st_rdev; +#else + statb[6] = 0; +#endif + statb[7] = buf.st_size; + statb[8] = buf.st_atime; + statb[9] = buf.st_mtime; + statb[10] = buf.st_ctime; + statb[6] = 0; +#if HAVE_ST_BLKSIZE + statb[11] = buf.st_blksize; +#else + statb[11] = -1; +#endif +#if HAVE_ST_BLOCKS + statb[12] = buf.st_blocks; +#else + statb[12] = -1; +#endif + return err; +#else /* !HAVE_LSTAT */ + return errno = ENOSYS; +#endif /* !HAVE_LSTAT */ +} diff --git a/gcc/f/runtime/libU77/ltime_.c b/gcc/f/runtime/libU77/ltime_.c new file mode 100644 index 000000000000..151ac6c9b550 --- /dev/null +++ b/gcc/f/runtime/libU77/ltime_.c @@ -0,0 +1,54 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +/* fixme: do we need to use TM_IN_SYS_TIME? */ +#if TIME_WITH_SYS_TIME +# include +# include +#else +# if HAVE_SYS_TIME_H +# include +# else +# include +# endif +#endif +#include "f2c.h" + +#ifdef KR_headers +/* Subroutine */ int G77_ltime_0 (stime, tarray) + integer *stime, tarray[9]; +#else +/* Subroutine */ int G77_ltime_0 (const integer * stime, integer tarray[9]) +#endif +{ + struct tm *lt; + lt = localtime ((time_t *) stime); + tarray[0] = lt->tm_sec; + tarray[1] = lt->tm_min; + tarray[2] = lt->tm_hour; + tarray[3] = lt->tm_mday; + tarray[4] = lt->tm_mon; + tarray[5] = lt->tm_year; + tarray[6] = lt->tm_wday; + tarray[7] = lt->tm_yday; + tarray[8] = lt->tm_isdst; + return 0; +} diff --git a/gcc/f/runtime/libU77/mclock_.c b/gcc/f/runtime/libU77/mclock_.c new file mode 100644 index 000000000000..6b7e81b1e045 --- /dev/null +++ b/gcc/f/runtime/libU77/mclock_.c @@ -0,0 +1,47 @@ +/* Copyright (C) 1996 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if TIME_WITH_SYS_TIME +# include +# include +#else +# if HAVE_SYS_TIME_H +# include +# else +# include +# endif +#endif +#include "f2c.h" + +/* Reported by wd42ej@sgi83.wwb.noaa.gov (Russ Jones AUTO-Sun3) on AIX. */ + +#ifdef KR_headers +longint G77_mclock_0 () +#else +longint G77_mclock_0 (void) +#endif +{ +#if HAVE_CLOCK + return clock (); +#else + return -1; +#endif +} diff --git a/gcc/f/runtime/libU77/perror_.c b/gcc/f/runtime/libU77/perror_.c new file mode 100644 index 000000000000..26d8582dbccf --- /dev/null +++ b/gcc/f/runtime/libU77/perror_.c @@ -0,0 +1,48 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include +#include +#if HAVE_STRING_H +# include +#else +# include +#endif +#include "f2c.h" + +#ifdef KR_headers +/* Subroutine */ int G77_perror_0 (str, Lstr) + char *str; ftnlen Lstr; +#else +/* Subroutine */ int G77_perror_0 (const char *str, const ftnlen Lstr) +#endif +{ + char buff[1000]; + char *bp, *blast; + + /* same technique as `system' -- what's wrong with malloc? */ + blast = buff + (Lstr < 1000 ? Lstr : 1000); + for (bp = buff ; bp +#endif +#include "f2c.h" +#ifndef RAND_MAX +# define RAND_MAX 2147483647 /* from SunOS */ +#endif + +/* We could presumably do much better than the traditional libc + version, though at least the glibc one is reasonable, it seems. + For the sake of the innocent, I'm not sure we should really do + this... */ + +/* Note this is per SunOS -- other s may have no arg. */ + +#ifdef KR_headers +doublereal G77_rand_0 (flag) + integer *flag; +#else +doublereal G77_rand_0 (integer *flag) +#endif +{ + switch (*flag) { + case 0: + break; + case 1: + srand (0); /* Arbitrary choice of initialiser. */ + break; + default: + srand (*flag); + } + return (float) rand () / RAND_MAX; +} diff --git a/gcc/f/runtime/libU77/rename_.c b/gcc/f/runtime/libU77/rename_.c new file mode 100644 index 000000000000..e8a4bf6523c4 --- /dev/null +++ b/gcc/f/runtime/libU77/rename_.c @@ -0,0 +1,53 @@ +/* Copyright (C) 1995, 1997 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if HAVE_STDLIB_H +# include +#endif +#include +#include +#include "f2c.h" + +#ifdef KR_headers +void g_char (); + +integer G77_rename_0 (path1, path2, Lpath1, Lpath2) + char *path1, *path2; ftnlen Lpath1, Lpath2; +#else +void g_char(const char *a, ftnlen alen, char *b); + +integer G77_rename_0 (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2) +#endif +{ + char *buff1, *buff2; + char *bp, *blast; + int i; + + buff1 = malloc (Lpath1+1); + if (buff1 == NULL) return -1; + g_char (path1, Lpath1, buff1); + buff2 = malloc (Lpath2+1); + if (buff2 == NULL) return -1; + g_char (path2, Lpath2, buff2); + i = rename (buff1, buff2); + free (buff1); free (buff2); + return i ? errno : 0; +} diff --git a/gcc/f/runtime/libU77/secnds_.c b/gcc/f/runtime/libU77/secnds_.c new file mode 100644 index 000000000000..64eb76e2fb9f --- /dev/null +++ b/gcc/f/runtime/libU77/secnds_.c @@ -0,0 +1,51 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include +#if TIME_WITH_SYS_TIME +# include +# include +#else +# if HAVE_SYS_TIME_H +# include +# else +# include +# endif +#endif +#include + +#include "f2c.h" + +/* This is a VMS intrinsic. */ + +doublereal G77_secnds_0 (real *r) +{ + struct tm *lt; + time_t clock; + float f; + + clock = time (NULL); + lt = localtime (&clock); + f= (3600.0*((real)lt->tm_hour) + 60.0*((real)lt->tm_min) + + (real)lt->tm_sec - *r); + return f; +} + diff --git a/gcc/f/runtime/libU77/second_.c b/gcc/f/runtime/libU77/second_.c new file mode 100644 index 000000000000..a984cf9e3d23 --- /dev/null +++ b/gcc/f/runtime/libU77/second_.c @@ -0,0 +1,26 @@ +/* Copyright (C) 1996 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include "f2c.h" + +doublereal G77_second_0 () { + extern doublereal G77_etime_0 (); + real tarray[2]; + + return G77_etime_0 (tarray); +} diff --git a/gcc/f/runtime/libU77/sleep_.c b/gcc/f/runtime/libU77/sleep_.c new file mode 100644 index 000000000000..36e1b8d9a7b5 --- /dev/null +++ b/gcc/f/runtime/libU77/sleep_.c @@ -0,0 +1,37 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if HAVE_UNISTD_H +# include +#endif +#include "f2c.h" + +/* Subroutine */ +#ifdef KR_headers +int G77_sleep_0 (seconds) + integer *seconds; +#else +int G77_sleep_0 (const integer *seconds) +#endif +{ + (void) sleep ((unsigned int) *seconds); + return 0; +} diff --git a/gcc/f/runtime/libU77/srand_.c b/gcc/f/runtime/libU77/srand_.c new file mode 100644 index 000000000000..8edc62e4fe03 --- /dev/null +++ b/gcc/f/runtime/libU77/srand_.c @@ -0,0 +1,37 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if STDC_HEADERS +# include +#endif +#include "f2c.h" + +/* Subroutine */ +#ifdef KR_headers +int G77_srand_0 (seed) + integer *seed; +#else +int G77_srand_0 (const integer *seed) +#endif +{ + srand ((unsigned int) *seed); + return 0; +} diff --git a/gcc/f/runtime/libU77/stat_.c b/gcc/f/runtime/libU77/stat_.c new file mode 100644 index 000000000000..b24f38922212 --- /dev/null +++ b/gcc/f/runtime/libU77/stat_.c @@ -0,0 +1,79 @@ +/* Copyright (C) 1995, 1997 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include +#if HAVE_STDLIB_H +# include +#endif +#include +#include +#include "f2c.h" + +#ifdef KR_headers +void g_char (); + +integer G77_stat_0 (name, statb, Lname) + char *name; + integer statb[13]; + ftnlen Lname; +#else +void g_char(const char *a, ftnlen alen, char *b); + +integer G77_stat_0 (const char *name, integer statb[13], const ftnlen Lname) +#endif +{ + char *buff; + char *bp, *blast; + int err; + struct stat buf; + + buff = malloc (Lname+1); + if (buff == NULL) return -1; + g_char (name, Lname, buff); + err = stat (buff, &buf); + free (buff); + statb[0] = buf.st_dev; + statb[1] = buf.st_ino; + statb[2] = buf.st_mode; + statb[3] = buf.st_nlink; + statb[4] = buf.st_uid; + statb[5] = buf.st_gid; +#if HAVE_ST_RDEV + statb[6] = buf.st_rdev; /* not posix */ +#else + statb[6] = 0; +#endif + statb[7] = buf.st_size; + statb[8] = buf.st_atime; + statb[9] = buf.st_mtime; + statb[10] = buf.st_ctime; +#if HAVE_ST_BLKSIZE + statb[11] = buf.st_blksize; /* not posix */ +#else + statb[11] = -1; +#endif +#if HAVE_ST_BLOCKS + statb[12] = buf.st_blocks; /* not posix */ +#else + statb[12] = -1; +#endif + return err; +} diff --git a/gcc/f/runtime/libU77/symlnk_.c b/gcc/f/runtime/libU77/symlnk_.c new file mode 100644 index 000000000000..d15e45287588 --- /dev/null +++ b/gcc/f/runtime/libU77/symlnk_.c @@ -0,0 +1,62 @@ +/* Copyright (C) 1995, 1997 Free Software Foundation, Inc. +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if HAVE_STDLIB_H +# include +#else +# include +#endif +#if HAVE_UNISTD_H +# include +#endif +#include +#include +#include "f2c.h" + +#ifdef KR_headers +void g_char (); + +integer G77_symlnk_0 (path1, path2, Lpath1, Lpath2) + char *path1, *path2; ftnlen Lpath1, Lpath2; +#else +void g_char(const char *a, ftnlen alen, char *b); + +integer G77_symlnk_0 (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2) +#endif +{ +#if HAVE_SYMLINK + char *buff1, *buff2; + char *bp, *blast; + int i; + + buff1 = (char *) malloc (Lpath1+1); + if (buff1 == NULL) return -1; + g_char (path1, Lpath1, buff1); + buff2 = (char *) malloc (Lpath2+1); + if (buff2 == NULL) return -1; + g_char (path2, Lpath2, buff2); + i = symlink (buff1, buff2); + free (buff1); free (buff2); + return i ? errno : 0; +#else /* !HAVE_SYMLINK */ + return errno = ENOSYS; +#endif /* !HAVE_SYMLINK */ +} diff --git a/gcc/f/runtime/libU77/system_clock_.c b/gcc/f/runtime/libU77/system_clock_.c new file mode 100644 index 000000000000..d5cbaac0608a --- /dev/null +++ b/gcc/f/runtime/libU77/system_clock_.c @@ -0,0 +1,64 @@ +/* Copyright (C) 1996 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if TIME_WITH_SYS_TIME +# include +# include +#else +# if HAVE_SYS_TIME_H +# include +# else +# include +# endif +#endif +#include +#include +#if HAVE_UNISTD_H +# include +#endif +#include "f2c.h" + +#ifdef KR_headers +int G77_system_clock_0 (count, count_rate, count_max) + integer *count, *count_rate, *count_max; +#else +int G77_system_clock_0 (integer *count, integer *count_rate, integer *count_max) +#endif +{ + struct tms buffer; + unsigned long cnt; +#ifdef _SC_CLK_TCK + *count_rate = sysconf(_SC_CLK_TCK); +#elif defined CLOCKS_PER_SECOND + *count_rate = CLOCKS_PER_SECOND; +#elif defined CLK_TCK + *count_rate = CLK_TCK; +#else + #error Dont know clock tick length +#endif + *count_max = INT_MAX; /* dubious */ + cnt = times (&buffer); + if (cnt > (unsigned long) (*count_max)) + *count = *count_max; /* also dubious */ + else + *count = cnt; + return 0; +} diff --git a/gcc/f/runtime/libU77/time_.c b/gcc/f/runtime/libU77/time_.c new file mode 100644 index 000000000000..73894b0b4136 --- /dev/null +++ b/gcc/f/runtime/libU77/time_.c @@ -0,0 +1,46 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include +#if TIME_WITH_SYS_TIME +# include +# include +#else +# if HAVE_SYS_TIME_H +# include +# else +# include +# endif +#endif +#include "f2c.h" + +/* As well as this external function some compilers have an intrinsic + subroutine which fills a character argument (which is the VMS way) + -- caveat emptor. */ +#ifdef KR_headers +longint G77_time_0 () +#else +longint G77_time_0 (void) +#endif +{ + /* There are potential problems with the cast of the time_t here. */ + return time (NULL); +} diff --git a/gcc/f/runtime/libU77/ttynam_.c b/gcc/f/runtime/libU77/ttynam_.c new file mode 100644 index 000000000000..f69aa43f564c --- /dev/null +++ b/gcc/f/runtime/libU77/ttynam_.c @@ -0,0 +1,57 @@ +/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if STDC_HEADERS +# include +#endif +#if HAVE_UNISTD_H +# include /* POSIX for ttyname */ +#endif +#include +#if HAVE_STRING_H +# include +#else +# include +#endif +#include "f2c.h" + +#ifdef KR_headers +extern void s_copy (); +extern integer G77_fnum_0 (); +/* Character */ void G77_ttynam_0 (ret_val, ret_val_len, lunit) + char *ret_val; ftnlen ret_val_len; integer *lunit +#else +extern integer G77_fnum_0 (integer *lunit); +extern void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb); +/* Character */ void G77_ttynam_0 (char *ret_val, ftnlen ret_val_len, integer *lunit) +#endif +{ + size_t i; + char *p; + + p = ttyname (G77_fnum_0 (lunit)); + if (p != NULL) { + i = strlen (p); + s_copy (ret_val, p, ret_val_len, i); + } else { + s_copy (ret_val, " ", ret_val_len, 1); + } +} diff --git a/gcc/f/runtime/libU77/u77-test.f b/gcc/f/runtime/libU77/u77-test.f new file mode 100644 index 000000000000..11c5ecae4492 --- /dev/null +++ b/gcc/f/runtime/libU77/u77-test.f @@ -0,0 +1,178 @@ +*** Some random stuff for testing libU77. Should be done better. It's +* hard to test things where you can't guarantee the result. Have a +* good squint at what it prints, though detected errors will cause +* starred messages. + + integer i, j, k, ltarray (9), idat (3), count, rate, count_max, + + pid + real tarray1(2), tarray2(2), r1, r2, etime + intrinsic getpid, getuid, getgid, ierrno, gerror, + + fnum, isatty, getarg, access, unlink, fstat, + + stat, lstat, getcwd, gmtime, hostnm, etime, chmod, + + chdir, fgetc, fputc, system_clock, second, idate, secnds, + + time, ctime, fdate, ttynam + external lenstr + logical l + character gerr*80, c*1 + character ctim*25, line*80, lognam*20, wd*100, line2*80 + integer fstatb (13), statb (13) + integer *2 i2zero + + ctim = ctime(time()) + WRITE (6,'(A/)') '1 GNU libU77 test at: ' // ctim + write (6,'(A,I3,'', '',I3)') + + ' Logical units 5 and 6 correspond (FNUM) to' + + // ' Unix i/o units ', fnum(5), fnum(6) + if (lnblnk('foo ').ne.3 .or. len_trim('foo ').ne.3) then + print *, 'LNBLNK or LEN_TRIM failed' + call exit(1) + end if + l= isatty(6) + line2 = ttynam(6) + if (l) then + line = 'and 6 is a tty device (ISATTY) named '//line2 + else + line = 'and 6 isn''t a tty device (ISATTY)' + end if + write (6,'(1X,A)') line(:lenstr(line)) + pid = getpid() + WRITE (6,'(A,I10)') ' Process id (GETPID): ', pid + WRITE (6,'(A,I10)') ' User id (GETUID): ', GETUID () + WRITE (6,'(A,I10)') ' Group id (GETGID): ', GETGID () + WRITE (6,*) 'If you have the `id'' program, the following call of' + + // ' SYSTEM should agree with the above' + call flush(6) + CALL SYSTEM ('echo " " `id`') + call flush + call getlog (lognam) + write (6,*) 'Login name (GETLOG): ', lognam + call umask(0, mask) + write(6,*) 'UMASK returns', mask + call umask(mask) + ctim = fdate() + write (6,*) 'FDATE returns: ', ctim + j=time() + call ltime (j, ltarray) + write (6,'(1x,a,9i4)') 'LTIME returns:', ltarray + call gmtime (j, ltarray) + write (6,'(1x,a,9i4)') 'GMTIME returns:', ltarray + call system_clock(count, rate, count_max) + write(6,*) 'SYSTEM_CLOCK returns: ', count, rate, count_max + write (6,*) 'Sleeping for 1 second (SLEEP) ...' + call sleep (1) + write (6,*) 'Looping 10,000,000 times ...' + do i=1,10*1000*1000 + end do + r1= etime (tarray1) + if (r1.ne.tarray1(1)+tarray1(2)) + + write (6,*) '*** ETIME didn''t return sum of the array: ', + + r1, ' /= ', tarray1 + r2= dtime (tarray2) + if (abs (r1-r2).gt.1.0) write (6,*) + + 'Results of ETIME and DTIME differ by more than a second:', + + i, j + write (6,'(A,3F10.3)') + + ' Elapsed total, user, system time (ETIME): ', + + r1, tarray1 + call idate(i,j,k) + call idate (idat) + write (6,*) 'IDATE d,m,y: ',idat + print *, '... and the VXT version: ', i,j,k + call time(line(:8)) + print *, line(:8) + write (6,*) 'SECNDS(0.0) returns: ',secnds(0.0) + write (6,*) 'SECOND returns: ', second() + call dumdum(r1) + call second(r1) + write (6,*) 'CALL SECOND returns: ', r1 + i = getcwd(wd) + if (i.ne.0) then + call perror ('*** getcwd') + else + write (6,*) 'Current directory is "'//wd(:lenstr(wd))//'"' + end if + call chdir ('.',i) + if (i.ne.0) write (6,*) '***CHDIR to ".": ', i + i=hostnm(wd) + if(i.ne.0) then + call perror ('*** hostnm') + else + write (6,*) 'Host name is ', wd(:lenstr(wd)) + end if + i = access('/dev/null ', 'rw') + if (i.ne.0) write (6,*) '***Read/write ACCESS to /dev/null: ', i + write (6,*) 'Creating file "foo" for testing...' + open (3,file='foo',status='UNKNOWN') + rewind 3 + call fputc(3, 'c',i) + call fputc(3, 'd',j) + if (i+j.ne.0) write(6,*) '***FPUTC: ', i +C why is it necessary to reopen? + close(3) + open(3,file='foo',status='old') + call fseek(3,0,0,*10) + go to 20 + 10 write(6,*) '***FSEEK failed' + 20 call fgetc(3, c,i) + if (i.ne.0) write(6,*) '***FGETC: ', i + if (c.ne.'c') write(6,*) '***FGETC read the wrong thing: ', + + ichar(c) + i= ftell(3) + if (i.ne.1) write(6,*) '***FTELL offset: ', i + call chmod ('foo', 'a+w',i) + if (i.ne.0) write (6,*) '***CHMOD of "foo": ', i + i = fstat (3, fstatb) + if (i.ne.0) write (6,*) '***FSTAT of "foo": ', i + i = stat ('foo', statb) + if (i.ne.0) write (6,*) '***STAT of "foo": ', i + write (6,*) ' with stat array ', statb + if (statb(5).ne.getuid () .or. statb(6).ne.getgid() .or. statb(4) + + .ne. 1) write (6,*) '*** FSTAT uid, gid or nlink is wrong' + do i=1,13 + if (fstatb (i) .ne. statb (i)) + + write (6,*) '*** FSTAT and STAT don''t agree on '// ' + + array element ', i, ' value ', fstatb (i), statb (i) + end do + i = lstat ('foo', fstatb) + do i=1,13 + if (fstatb (i) .ne. statb (i)) + + write (6,*) '*** LSTAT and STAT don''t agree on '// ' + + array element ', i, ' value ', fstatb (i), statb (i) + end do + +C in case it exists already: + call unlink ('bar',i) + call link ('foo ', 'bar ',i) + if (i.ne.0) + + write (6,*) '***LINK "foo" to "bar" failed: ', i + call unlink ('foo',i) + if (i.ne.0) write (6,*) '***UNLINK "foo" failed: ', i + call unlink ('foo',i) + if (i.eq.0) write (6,*) '***UNLINK "foo" again: ', i + call gerror (gerr) + i = ierrno() + write (6,'(A,I3,A/1X,A)') ' The current error number is: ', + + i, + + ' and the corresponding message is:', gerr(:lenstr(gerr)) + write (6,*) 'This is sent to stderr prefixed by the program name' + call getarg (0, line) + call perror (line (:lenstr (line))) + call unlink ('bar') + WRITE (6,*) 'You should see exit status 1' + CALL EXIT(1) + 99 END + + integer function lenstr (str) +C return length of STR not including trailing blanks, but always +C return >0 + character *(*) str + if (str.eq.' ') then + lenstr=1 + else + lenstr = lnblnk (str) + end if + end +* just make sure SECOND() doesn't "magically" work the second time. + subroutine dumdum(r) + r = 3.14159 + end diff --git a/gcc/f/runtime/libU77/umask_.c b/gcc/f/runtime/libU77/umask_.c new file mode 100644 index 000000000000..203acfa916f2 --- /dev/null +++ b/gcc/f/runtime/libU77/umask_.c @@ -0,0 +1,34 @@ +/* Copyright (C) 1996 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include +#include +#include "f2c.h" + +#ifdef KR_headers +integer G77_umask_0 (mask) + integer *mask; +#else +integer G77_umask_0 (integer *mask) +#endif +{ + return umask ((mode_t) *mask); +} diff --git a/gcc/f/runtime/libU77/unlink_.c b/gcc/f/runtime/libU77/unlink_.c new file mode 100644 index 000000000000..5e7edf213bc2 --- /dev/null +++ b/gcc/f/runtime/libU77/unlink_.c @@ -0,0 +1,55 @@ +/* Copyright (C) 1995, 1997 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#if HAVE_STDLIB_H +# include +#else +# include +#endif +#if HAVE_UNISTD_H +# include +#endif +#include +#include +#include "f2c.h" + +#ifdef KR_headers +void g_char (); + +integer G77_unlink_0 (str, Lstr) + char *str; ftnlen Lstr; +#else +void g_char(const char *a, ftnlen alen, char *b); + +integer G77_unlink_0 (const char *str, const ftnlen Lstr) +#endif +{ + char *buff; + char *bp, *blast; + int i; + + buff = malloc (Lstr+1); + if (buff == NULL) return -1; + g_char (str, Lstr, buff); + i = unlink (buff); + free (buff); + return i ? errno : 0; /* SGI version returns -1 on failure. */ +} diff --git a/gcc/f/runtime/libU77/vxtidate_.c b/gcc/f/runtime/libU77/vxtidate_.c new file mode 100644 index 000000000000..c517f29419e1 --- /dev/null +++ b/gcc/f/runtime/libU77/vxtidate_.c @@ -0,0 +1,55 @@ +/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include +#if TIME_WITH_SYS_TIME +# include +# include +#else +# if HAVE_SYS_TIME_H +# include +# else +# include +# endif +#endif +#include "f2c.h" + +/* VMS and Irix versions (at least) differ from libU77 elsewhere */ + +/* VMS style: */ + +/* Subroutine */ +#ifdef KR_headers +int G77_vxtidate_0 (m, d, y) + integer *y, *m, *d; +#else +int G77_vxtidate_0 (integer *m, integer *d, integer *y) +#endif +{ + struct tm *lt; + time_t tim; + tim = time(NULL); + lt = localtime(&tim); + *y = lt->tm_year; + *m = lt->tm_mon+1; + *d = lt->tm_mday; + return 0; +} diff --git a/gcc/f/runtime/libU77/vxttime_.c b/gcc/f/runtime/libU77/vxttime_.c new file mode 100644 index 000000000000..054bb45a89a9 --- /dev/null +++ b/gcc/f/runtime/libU77/vxttime_.c @@ -0,0 +1,54 @@ +/* Copyright (C) 1995 Free Software Foundation, Inc. +This file is part of GNU Fortran libU77 library. + +This library is free software; you can redistribute it and/or modify it +under the terms of the GNU Library General Public License as published +by the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with GNU Fortran; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif +#include +#if TIME_WITH_SYS_TIME +# include +# include +#else +# if HAVE_SYS_TIME_H +# include +# else +# include +# endif +#endif +#if HAVE_STRING_H +# include +#else +# include +#endif +#include "f2c.h" + +/* Subroutine */ +#ifdef KR_headers +void G77_vxttime_0 (chtime, Lchtime) + char chtime[8]; + ftnlen Lchtime; +#else +void G77_vxttime_0 (char chtime[8], const ftnlen Lchtime) +#endif +{ + time_t tim; + char *ctim; + tim = time(NULL); + ctim = ctime (&tim); + strncpy (chtime, ctim+11, 8); +} diff --git a/gcc/f/runtime/permission.netlib b/gcc/f/runtime/permission.netlib new file mode 100644 index 000000000000..261b719bc57e --- /dev/null +++ b/gcc/f/runtime/permission.netlib @@ -0,0 +1,23 @@ +/**************************************************************** +Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore. + +Permission to use, copy, modify, and distribute this software +and its documentation for any purpose and without fee is hereby +granted, provided that the above copyright notice appear in all +copies and that both that the copyright notice and this +permission notice and warranty disclaimer appear in supporting +documentation, and that the names of AT&T, Bell Laboratories, +Lucent or Bellcore or any of their entities not be used in +advertising or publicity pertaining to distribution of the +software without specific, written prior permission. + +AT&T, Lucent and Bellcore disclaim all warranties with regard to +this software, including all implied warranties of +merchantability and fitness. In no event shall AT&T, Lucent or +Bellcore be liable for any special, indirect or consequential +damages or any damages whatsoever resulting from loss of use, +data or profits, whether in an action of contract, negligence or +other tortious action, arising out of or in connection with the +use or performance of this software. +****************************************************************/ + diff --git a/gcc/f/runtime/readme.netlib b/gcc/f/runtime/readme.netlib new file mode 100644 index 000000000000..22efbfe801e9 --- /dev/null +++ b/gcc/f/runtime/readme.netlib @@ -0,0 +1,585 @@ + +====== old index for f2c, now "readme from f2c" ============ + +FILES: + +f2c.h Include file necessary for compiling output of the converter. + See the second NOTE below. + +f2c.1 Man page for f2c. + +f2c.1t Source for f2c.1 (to be processed by troff -man or nroff -man). + +libf77 Library of non I/O support routines the generated C may need. + Fortran main programs result in a C function named MAIN__ that + is meant to be invoked by the main() in libf77. + +libi77 Library of Fortran I/O routines the generated C may need. + Note that some vendors (e.g., BSD, Sun and MIPS) provide a + libF77 and libI77 that are incompatible with f2c -- they + provide some differently named routines or routines with the + names that f2c expects, but with different calling sequences. + On such systems, the recommended procedure is to merge + libf77 and libi77 into a single library, say libf2c, and to + install it where you can access it by specifying -lf2c . The + definition of link_msg in sysdep.c assumes this arrangement. + + Both libf77 and libi77 are bundles, meant to be unpacked by the + Bourne (or Korn) shell. MS-DOS users can use the MKS Toolkit + to unpack libf77 and libi77. + +libf2c.zip + Only available by ftp: combination of libf77 and libi77, with + Unix and PC makefiles. + +f2c.ps Postscript for a technical report on f2c. After you strip the + mail header, the first line should be "%!PS". + +fixes The complete change log, reporting bug fixes and other changes. + (Some recent change-log entries are given below). + +fc A shell script that uses f2c and imitates much of the behavior + of commonly found f77 commands. You will almost certainly + need to adjust some of the shell-variable assignments to make + this script work on your system. + + +SUBDIRECTORY: + +f2c/src Source for the converter itself, including a file of checksums + and source for a program to compute the checksums (to verify + correct transmission of the source), is available: ask netlib + (e.g., netlib@netlib.bell-labs.com) to + send all from f2c/src + If the checksums show damage to just a few source files, or if + the change log file (see "fixes" below) reports corrections to + some source files, you can request those files individually + "from f2c/src". For example, to get defs.h and xsum0.out, you + would ask netlib to + send defs.h xsum0.out from f2c/src + "all from f2c/src" is about 640 kilobytes long; for convenience + (and checksums), it includes copies of f2c.h, f2c.1, and f2c.1t. + + Tip: if asked to send over 99,000 bytes in one request, netlib + breaks the shipment into 1000 line pieces and sends each piece + separately (since otherwise some mailers might gag). To avoid + the hassle of reassembling the pieces, try to keep each request + under 99,000 bytes long. The final number in each line of + xsum0.out gives the length of each file in f2c/src. For + example, + send exec.c expr.c from f2c/src + send format.c format_data.c from f2c/src + will give you slightly less hassle than + send exec.c expr.c format.c format_data.c from f2c/src + Alternatively, if all the mailers in your return path allow + long messages, you can supply an appropriate mailsize line in + your netlib request, e.g. + mailsize 200k + send exec.c expr.c format.c format_data.c from f2c/src + + If you have trouble generating gram.c, you can ask netlib to + send gram.c from f2c/src + Then `xsum gram.c` should report + gram.c 5529f4f 58745 + Alternatively, if you have bison, you might get a working + gram.c by saying + make gram.c YACC=bison YFLAGS=-y + (but please do not complain if this gives a bad gram.c). + +NOTE: For now, you may exercise f2c by sending netlib a message whose + first line is "execute f2c" and whose remaining lines are + the Fortran 77 source that you wish to have converted. + Return mail brings you the resulting C, with f2c's error + messages between #ifdef uNdEfInEd and #endif at the end. + (To understand line numbers in the error messages, regard + the "execute f2c" line as line 0. It is stripped away by + the netlib software before f2c sees your Fortran input.) + Options described in the man page may be transmitted to + netlib by having the first line of input be a comment + whose first 6 characters are "c$f2c " and whose remaining + characters are the desired options, e.g., "c$f2c -R -u". + + You may say "execute f2c" in the Subject line instead of (but + *not* in addition to) in the first line of the message body. + + The incoming Fortran is saved, at least for a while. Don't + send any secrets! + + +BUGS: Please send bug reports (including the shortest example + you can find that illustrates the bug) to research!dmg + or dmg@bell-labs.com . You might first check whether + the bug goes away when you turn optimization off. + + +NOTE: f2c.h defines several types, e.g., real, integer, doublereal. + The definitions in f2c.h are suitable for most machines, but if + your machine has sizeof(double) > 2*sizeof(long), you may need + to adjust f2c.h appropriately. f2c assumes + sizeof(doublecomplex) = 2*sizeof(doublereal) + sizeof(doublereal) = sizeof(complex) + sizeof(doublereal) = 2*sizeof(real) + sizeof(real) = sizeof(integer) + sizeof(real) = sizeof(logical) + sizeof(real) = 2*sizeof(shortint) + EQUIVALENCEs may not be translated correctly if these + assumptions are violated. + + On machines, such as those using a DEC Alpha processor, on + which sizeof(short) == 2, sizeof(int) == sizeof(float) == 4, + and sizeof(long) == sizeof(double) == 8, it suffices to + modify f2c.h by removing the first occurrence of "long " + on each line containing "long ", e.g., by issuing the + commands + mv f2c.h f2c.h0 + sed 's/long //' f2c.h0 >f2c.h + On such machines, one can enable INTEGER*8 by uncommenting + the typedef of longint in f2c.h, so it reads + typedef long longint; + by compiling libI77 with -DAllow_TYQUAD, and by adjusting + libF77/makefile as described in libF77/README. + + Some machines may have sizeof(int) == 4 and + sizeof(long long) == 8. On such machines, adjust f2c.h + by changing "long int " to "long long ", e.g., by saying + mv f2c.h f2c.h0 + sed 's/long int /long long /' f2c.h0 >f2c.h + One can enable INTEGER*8 on such machines as described + above, but with + typedef long long longint; + + There exists a C compiler that objects to the lines + typedef VOID C_f; /* complex function */ + typedef VOID H_f; /* character function */ + typedef VOID Z_f; /* double complex function */ + in f2c.h . If yours is such a compiler, do two things: + 1. Complain to your vendor about this compiler bug. + 2. Find the line + #define VOID void + in f2c.h and change it to + #define VOID int + (For readability, the f2c.h lines shown above have had two + tabs inserted before their first character.) + +FTP: All the material described above is now available by anonymous + ftp from netlib.bell-labs.com (login: anonymous; Password: your + E-mail address; cd netlib/f2c). Note that you can say, e.g., + + cd /netlib/f2c/src + binary + prompt + mget *.Z + + to get all the .Z files in src. You must uncompress the .Z + files once you have a copy of them, e.g., by + + uncompress *.Z + + Subdirectory msdos contains two PC versions of f2c, + f2c.exe.Z and f2cx.exe.Z; the latter uses extended memory. + The README in that directory provides more details. + + Changes appear first in the f2c files available by E-mail + from netlib@netlib.bell-labs.com. If the deamons work right, + changed files are available the next day by ftp from + netlib.bell-labs.com. In due course, they reach other netlib servers. + +CHANGE NOTIFICATION: + Send the E-mail message + subscribe f2c + to netlib@netlib.bell-labs.com to request notification of new and + changed f2c files. (Beware that automatically sent change + notifications may reach you before changes have reached + ftp://netlib.bell-labs.com/netlib/f2c or to other netlib servers.) + Send the E-mail message + unsubscribe f2c + to recant your notification request. + +----------------- +Recent change log (partial) +----------------- + +Mon May 13 23:35:26 EDT 1996 + Recognize Fortran 90's /= as a synonym for .NE.. (<> remains a +synonym for .NE..) + Emit an empty int function of no arguments to supply an external +name to named block data subprograms (so they can be called somewhere +to force them to be loaded from a library). + Fix bug (memory fault) in handling the following illegal Fortran: + parameter(i=1) + equivalence(i,j) + end + Treat cdabs, cdcos, cdexp, cdlog, cdsin, and cdsqrt as synonyms for +the double complex intrinsics zabs, zcos, zexp, zlog, zsin, and zsqrt, +respectively, unless -cd is specified. + Recognize the Fortran 90 bit-manipulation intrinsics btest, iand, +ibclr, ibits, ibset, ieor, ior, ishft, and ishftc, unless -i90 is +specified. Note that iand, ieor, and ior are thus now synonyms for +"and", "xor", and "or", respectively. + Add three macros (bit_test, bit_clear, bit_set) to f2c.h for use +with btest, ibclr, and ibset, respectively. Add new functions +[lq]bit_bits, [lq]bit_shift, and [lq]_bit_cshift to libF77 for +use with ibits, ishft, and ishftc, respectively. + Add integer function ftell(unit) (returning -1 on error) and +subroutine fseek(unit, offset, whence, *) to libI77 (with branch to +label * on error). + +Tue May 14 23:21:12 EDT 1996 + Fix glitch (possible memory fault, or worse) in handling multiple +entry points with names over 28 characters long. + +Mon Jun 10 01:20:16 EDT 1996 + Update netlib E-mail and ftp addresses in f2c/readme and +f2c/src/readme (which are different files) -- to reflect the upcoming +breakup of AT&T. + libf77: trivial tweaks to F77_aloc.c and system_.c; Version.c not +changed. + libi77: Adjust rsli.c and lread.c so internal list input with too +few items in the input string will honor end= . + +Mon Jun 10 22:59:57 EDT 1996 + Add Bits_per_Byte to sysdep.h and adjust definition of Table_size +to depend on Bits_per_Byte (forcing Table_size to be a power of 2); in +lex.c, change "comstart[c & 0xfff]" to "comstart[c & (Table_size-1)]" +to avoid an out-of-range subscript on end-of-file. + +Wed Jun 12 00:24:28 EDT 1996 + Fix bug in output.c (dereferencing a freed pointer) revealed in + print * !np in out_call in output.c clobbered by free + end !during out_expr. + +Wed Jun 19 08:12:47 EDT 1996 + f2c.h: add types uinteger, ulongint (for libF77); add qbit_clear +and qbit_set macros (in a commented-out section) for integer*8. + For integer*8, use qbit_clear and qbit_set for ibclr and ibset. + libf77: add casts to unsigned in [lq]bitshft.c. + +Thu Jun 20 13:30:43 EDT 1996 + Complain at character*(*) in common (rather than faulting). + Fix bug in recognizing hex constants that start with "16#" (e.g., +16#1234abcd, which is a synonym for z'1234abcd'). + Fix bugs in constant folding of expressions involving btest, ibclr, +and ibset. + Fix bug in constant folding of rshift(16#80000000, -31) (on a 32-bit +machine; more generally, the bug was in constant folding of +rshift(ibset(0,NBITS-1), 1-NBITS) when f2c runs on a machine with +long ints having NBITS bits. + +Mon Jun 24 07:58:53 EDT 1996 + Adjust struct Literal and newlabel() function to accommodate huge +source files (with more than 32767 newlabel() invocations). + Omit .c file when the .f file has a missing final end statement. + +Wed Jun 26 14:00:02 EDT 1996 + libi77: Add discussion of MXUNIT (highest allowed Fortran unit number) +to libI77/README. + +Fri Jun 28 14:16:11 EDT 1996 + Fix glitch with -onetrip: the temporary variable used for nonconstant +initial loop variable values was recycled too soon. Example: + do i = j+1, k + call foo(i+1) ! temp for j+1 was reused here + enddo + end + +Tue Jul 2 16:11:27 EDT 1996 + formatdata.c: add a 0 to the end of the basetype array (for TYBLANK) +(an omission that was harmless on most machines). + expr.c: fix a dereference of NULL that was only possible with buggy +input, such as + subroutine $sub(s) ! the '$' is erroneous + character s*(*) + s(1:) = ' ' + end + +Sat Jul 6 00:44:56 EDT 1996 + Fix glitch in the intrinsic "real" function when applied to a +complex (or double complex) variable and passed as an argument to +some intrinsic functions. Example: + complex a + b = sqrt(real(a)) + end + Fix glitch (only visible if you do not use f2c's malloc and the +malloc you do use is defective in the sense that malloc(0) returns 0) +in handling include files that end with another include (perhaps +followed by comments). + Fix glitch with character*(*) arguments named "h" and "i" when +the body of the subroutine invokes the intrinsic LEN function. + Arrange that after a previous "f2c -P foo.f" has produced foo.P, +running "f2c foo.P foo.f" will produce valid C when foo.f contains + call sub('1234') + end + subroutine sub(msg) + end +Specifically, the length argument in "call sub" is now suppressed. +With or without foo.P, it is also now suppressed when the order of +subprograms in file foo.f is reversed: + subroutine sub(msg) + end + call sub('1234') + end + Adjust copyright notices to reflect AT&T breakup. + +Wed Jul 10 09:25:49 EDT 1996 + Fix bug (possible memory fault) in handling erroneously placed +and inconsistent declarations. Example that faulted: + character*1 w(8) + call foo(w) + end + subroutine foo(m) + data h /0.5/ + integer m(2) ! should be before data + end + Fix bug (possible fault) in handling illegal "if" constructions. +Example (that faulted): + subroutine foo(i,j) + if (i) then ! bug: i is integer, not logical + else if (j) then ! bug: j is integer, not logical + endif + end + Fix glitch with character*(*) argument named "ret_len" to a +character*(*) function. + +Wed Jul 10 23:04:16 EDT 1996 + Fix more glitches in the intrinsic "real" function when applied to a +complex (or double complex) variable and passed as an argument to +some intrinsic functions. Example: + complex a, b + r = sqrt(real(conjg(a))) + sqrt(real(a*b)) + end + +Thu Jul 11 17:27:16 EDT 1996 + Fix a memory fault associated with complicated, illegal input. +Example: + subroutine goo + character a + call foo(a) ! inconsistent with subsequent def and call + end + subroutine foo(a) + end + call foo(a) + end + +Wed Jul 17 19:18:28 EDT 1996 + Fix yet another case of intrinsic "real" applied to a complex +argument. Example: + complex a(3) + x = sqrt(real(a(2))) ! gave error message about bad tag + end + +Mon Aug 26 11:28:57 EDT 1996 + Tweak sysdep.c for non-Unix systems in which process ID's can be +over 5 digits long. + +Tue Aug 27 08:31:32 EDT 1996 + Adjust the ishft intrinsic to use unsigned right shifts. (Previously, +a negative constant second operand resulted in a possibly signed shift.) + +Thu Sep 12 14:04:07 EDT 1996 + equiv.c: fix glitch with -DKR_headers. + libi77: fmtlib.c: fix bug in printing the most negative integer. + +Fri Sep 13 08:54:40 EDT 1996 + Diagnose some illegal appearances of substring notation. + +Tue Sep 17 17:48:09 EDT 1996 + Fix fault in handling some complex parameters. Example: + subroutine foo(a) + double complex a, b + parameter(b = (0,1)) + a = b ! f2c faulted here + end + +Thu Sep 26 07:47:10 EDT 1996 + libi77: fmt.h: for formatted writes of negative integer*1 values, +make ic signed on ANSI systems. If formatted writes of integer*1 +values trouble you when using a K&R C compiler, switch to an ANSI +compiler or use a compiler flag that makes characters signed. + +Tue Oct 1 14:41:36 EDT 1996 + Give a better error message when dummy arguments appear in data +statements. + +Thu Oct 17 13:37:22 EDT 1996 + Fix bug in typechecking arguments to character and complex (or +double complex) functions; the bug could cause length arguments +for character arguments to be omitted on invocations appearing +textually after the first invocation. For example, in + subroutine foo + character c + complex zot + call goo(zot(c), zot(c)) + end +the length was omitted from the second invocation of zot, and +there was an erroneous error message about inconsistent calling +sequences. + +Wed Dec 4 13:59:14 EST 1996 + Fix bug revealed by + subroutine test(cdum,rdum) + complex cdum + rdum=cos(real(cdum)) ! "Unexpected tag 3 in opconv_fudge" + end + Fix glitch in parsing "DO 10 D0 = 1, 10". + Fix glitch in parsing + real*8 x + real*8 x ! erroneous "incompatible type" message + call foo(x) + end + lib[FI]77/makefile: add comment about omitting -x under Solaris. + +Mon Dec 9 23:15:02 EST 1996 + Fix glitch in parameter adjustments for arrays whose lower +bound depends on a scalar argument. Example: + subroutine bug(p,z,m,n) + integer z(*),m,n + double precision p(z(m):z(m) + n) ! p_offset botched + call foo(p(0), p(n)) + end + libi77: complain about non-positive rec= in direct read and write +statements. + libf77: trivial adjustments; Version.c not changed. + +Wed Feb 12 00:18:03 EST 1997 + output.c: fix (seldom problematic) glitch in out_call: put parens +around the ... in a test of the form "if (q->tag == TADDR && ...)". + vax.c: fix bug revealed in the "psi_offset =" assignment in the +following example: + subroutine foo(psi,m) + integer z(100),m + common /a/ z + double precision psi(z(m):z(m) + 10) + call foo(m+1, psi(0),psi(10)) + end + +Mon Feb 24 23:44:54 EST 1997 + For consistency with f2c's current treatment of adjacent character +strings in FORMAT statements, recognize a Hollerith string following +a string (and merge adjacent strings in FORMAT statements). + +Wed Feb 26 13:41:11 EST 1997 + New libf2c.zip, a combination of the libf77 and libi77 bundles (and +available only by ftp). + libf77: adjust functions with a complex output argument to permit +aliasing it with input arguments. (For now, at least, this is just +for possible benefit of g77.) + libi77: tweak to ftell_.c for systems with strange definitions of +SEEK_SET, etc. + +Tue Apr 8 20:57:08 EDT 1997 + libf77: [cz]_div.c: tweaks invisible on most systems (that may +improve things slightly with optimized compilation on systems that use +gratuitous extra precision). + libi77: fmt.c: adjust to complain at missing numbers in formats +(but still treat missing ".nnn" as ".0"). + +Fri Apr 11 14:05:57 EDT 1997 + libi77: err.c: attempt to make stderr line buffered rather than +fully buffered. (Buffering is needed for format items T and TR.) + +Thu Apr 17 22:42:43 EDT 1997 + libf77: add F77_aloc.o to makefile (and makefile.u in libf2c.zip). + +Fri Apr 25 19:32:09 EDT 1997 + libf77: add [de]time_.c (which may give trouble on some systems). + +Tue May 27 09:18:52 EDT 1997 + libi77: ftell_.c: fix typo that caused the third argument to be +treated as 2 on some systems. + +Mon Jun 9 00:04:37 EDT 1997 + libi77 (and libf2c.zip): adjust include order in err.c lread.c wref.c +rdfmt.c to include fmt.h (etc.) after system includes. Version.c not +changed. + +Mon Jun 9 14:29:13 EDT 1997 + src/gram.c updated; somehow it did not reflect the change of +19961001 to gram.dcl. + +Mon Jul 21 16:04:54 EDT 1997 + proc.c: fix glitch in logic for "nonpositive dimension" message. + libi77: inquire.c: always include string.h (for possible use with +-DNON_UNIX_STDIO); Version.c not changed. + +Thu Jul 24 17:11:23 EDT 1997 + Tweak "Notice" to reflect the AT&T breakup -- we missed it when +updating the copyright notices in the source files last summer. + Adjust src/makefile so malloc.o is not used by default, but can +be specified with "make MALLOC=malloc.o". + Add comments to src/README about the "CRAY" T3E. + +Tue Aug 5 14:53:25 EDT 1997 + Add definition of calloc to malloc.c; this makes f2c's malloc +work on some systems where trouble hitherto arose because references +to calloc brought in the system's malloc. (On sensible systems, +calloc is defined separately from malloc. To avoid confusion on +other systems, f2c/malloc.c now defines calloc.) + libi77: lread.c: adjust to accord with a change to the Fortran 8X +draft (in 1990 or 1991) that rescinded permission to elide quote marks +in namelist input of character data; to get the old behavior, compile +with F8X_NML_ELIDE_QUOTES #defined. wrtfmt.o: wrt_G: tweak to print +the right number of 0's for zero under G format. + +Current timestamps of files in "all from f2c/src", sorted by time, +appear below (mm/dd/year hh:mm:ss). To bring your source up to date, +obtain source files with a timestamp later than the time shown in your +version.c. Note that the time shown in the current version.c is the +timestamp of the source module that immediately follows version.c below: + + 8/05/1997 14:51:56 xsum0.out + 8/05/1997 14:42:48 version.c + 8/05/1997 10:31:26 malloc.c + 7/24/1997 17:10:55 README + 7/24/1997 17:00:57 makefile + 7/24/1997 16:06:19 Notice + 7/21/1997 12:58:44 proc.c + 2/19/1997 13:34:09 lex.c + 2/11/1997 23:39:14 vax.c +12/22/1996 11:51:22 output.c +12/04/1996 13:07:53 gram.exec +10/17/1996 13:10:40 putpcc.c +10/01/1996 14:36:18 gram.dcl +10/01/1996 14:36:18 init.c +10/01/1996 14:36:18 defs.h +10/01/1996 14:36:17 data.c + 9/17/1996 17:29:44 expr.c + 9/12/1996 12:12:46 equiv.c + 8/27/1996 8:30:32 intr.c + 8/26/1996 9:41:13 sysdep.c + 7/09/1996 10:41:13 format.c + 7/09/1996 10:40:45 names.c + 7/04/1996 9:58:31 formatdata.c + 7/04/1996 9:55:45 sysdep.h + 7/04/1996 9:55:43 put.c + 7/04/1996 9:55:41 pread.c + 7/04/1996 9:55:40 parse_args.c + 7/04/1996 9:55:40 p1output.c + 7/04/1996 9:55:38 niceprintf.c + 7/04/1996 9:55:37 misc.c + 7/04/1996 9:55:36 memset.c + 7/04/1996 9:55:36 mem.c + 7/04/1996 9:55:35 main.c + 7/04/1996 9:55:33 io.c + 7/04/1996 9:55:30 exec.c + 7/04/1996 9:55:29 error.c + 7/04/1996 9:55:27 cds.c + 7/03/1996 15:47:49 xsum.c + 6/19/1996 7:04:27 f2c.h + 6/19/1996 2:52:05 defines.h + 5/13/1996 0:40:32 gram.head + 5/12/1996 23:37:11 f2c.1 + 5/12/1996 23:37:02 f2c.1t + 2/25/1994 2:07:19 parse.h + 2/22/1994 19:07:20 iob.h + 2/22/1994 18:56:53 p1defs.h + 2/22/1994 18:53:46 output.h + 2/22/1994 18:51:14 names.h + 2/22/1994 18:30:41 format.h + 1/18/1994 18:12:52 tokens + 3/06/1993 14:13:58 gram.expr + 1/28/1993 9:03:16 ftypes.h + 4/06/1990 0:00:57 gram.io + 2/03/1990 0:58:26 niceprintf.h + 1/07/1990 1:20:01 usignal.h +11/27/1989 8:27:37 machdefs.h + 7/01/1989 11:59:44 pccdefs.h diff --git a/gcc/f/src.c b/gcc/f/src.c new file mode 100644 index 000000000000..095c0481af99 --- /dev/null +++ b/gcc/f/src.c @@ -0,0 +1,436 @@ +/* src.c -- Implementation File + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + + Description: + Source-file functions to handle various combinations of case sensitivity + and insensitivity at run time. + + Modifications: +*/ + +#include "proj.h" +#include +#include "src.h" +#include "top.h" + +/* This array does a toupper (), but any valid char type is valid as an + index and returns identity if not a lower-case character. */ + +char ffesrc_toupper_[256]; + +/* This array does a tolower (), but any valid char type is valid as an + index and returns identity if not an upper-case character. */ + +char ffesrc_tolower_[256]; + +/* This array is set up so that, given a source-mapped character, the result + of indexing into this array will match an upper-cased character depending + on the source-mapped character's case and the established ffe_case_match() + setting. So the uppercase cells contain identies (e.g. ['A'] == 'A') + as long as uppercase matching is permitted (!FFE_caseLOWER) and the + lowercase cells contain uppercased identities (e.g. ['a'] == 'A') as long + as lowercase matching is permitted (!FFE_caseUPPER). Else the case + cells contain -1. _init_ is for the first character of a keyword, + and _noninit_ is for other characters. */ + +char ffesrc_char_match_init_[256]; +char ffesrc_char_match_noninit_[256]; + +/* This array is used to map input source according to the established + ffe_case_source() setting: for FFE_caseNONE, the array is all + identities; for FFE_caseUPPER, the lowercase cells contain + uppercased identities; and vice versa for FFE_caseLOWER. */ + +char ffesrc_char_source_[256]; + +/* This array is used to map an internally generated character so that it + will be accepted as an initial character in a keyword. The assumption + is that the incoming character is uppercase. */ + +char ffesrc_char_internal_init_[256]; + +/* This array is used to determine if a particular character is valid in + a symbol name according to the established ffe_case_symbol() setting: + for FFE_caseNONE, the array is all FFEBAD; for FFE_caseUPPER, the + lowercase cells contain a non-FFEBAD error code (FFEBAD_SYMBOL_UPPER_CASE); + and vice versa for FFE_caseLOWER. _init_ and _noninit_ distinguish + between initial and subsequent characters for the caseINITCAP case, + and their error codes are different for appropriate messages -- + specifically, _noninit_ contains a non-FFEBAD error code for all + except lowercase characters for the caseINITCAP case. + + See ffesrc_check_symbol_, it must be TRUE if this array is not all + FFEBAD. */ + +ffebad ffesrc_bad_symbol_init_[256]; +ffebad ffesrc_bad_symbol_noninit_[256]; + +/* Set TRUE if any element in ffesrc_bad_symbol (with an index representing + a character that can also be in the text of a token passed to + ffename_find, strictly speaking) is not FFEBAD. I.e., TRUE if it is + necessary to check token characters against the ffesrc_bad_symbol_ + array. */ + +bool ffesrc_check_symbol_; + +/* These are set TRUE if the kind of character (upper/lower) is ok as a match + in the context (initial/noninitial character of keyword). */ + +bool ffesrc_ok_match_init_upper_; +bool ffesrc_ok_match_init_lower_; +bool ffesrc_ok_match_noninit_upper_; +bool ffesrc_ok_match_noninit_lower_; + +/* Initialize table of alphabetic matches. */ + +void +ffesrc_init_1 () +{ + int i; + + for (i = 0; i < 256; ++i) + { + ffesrc_char_match_init_[i] = i; + ffesrc_char_match_noninit_[i] = i; + ffesrc_char_source_[i] = i; + ffesrc_char_internal_init_[i] = i; + ffesrc_toupper_[i] = i; + ffesrc_tolower_[i] = i; + ffesrc_bad_symbol_init_[i] = FFEBAD; + ffesrc_bad_symbol_noninit_[i] = FFEBAD; + } + + for (i = 'A'; i <= 'Z'; ++i) + ffesrc_tolower_[i] = tolower (i); + + for (i = 'a'; i <= 'z'; ++i) + ffesrc_toupper_[i] = toupper (i); + + ffesrc_check_symbol_ = (ffe_case_symbol () != FFE_caseNONE); + + ffesrc_ok_match_init_upper_ = (ffe_case_match () != FFE_caseLOWER); + ffesrc_ok_match_init_lower_ = (ffe_case_match () != FFE_caseUPPER) + && (ffe_case_match () != FFE_caseINITCAP); + ffesrc_ok_match_noninit_upper_ = (ffe_case_match () != FFE_caseLOWER) + && (ffe_case_match () != FFE_caseINITCAP); + ffesrc_ok_match_noninit_lower_ = (ffe_case_match () != FFE_caseUPPER); + + /* Note that '-' is used to flag an invalid match character. '-' is + somewhat arbitrary, actually. -1 was used, but that's not wise on a + system with unsigned chars as default -- it'd turn into 255 or some such + large positive number, which would sort higher than the alphabetics and + thus possibly cause problems. So '-' is picked just because it's never + likely to be a symbol character in Fortran and because it's "less than" + any alphabetic character. EBCDIC might see things differently, I don't + remember it well enough, but that's just tough -- lots of other things + might have to change to support EBCDIC -- anyway, some other character + could easily be picked. */ + +#define FFESRC_INVALID_SYMBOL_CHAR_ '-' + + if (!ffesrc_ok_match_init_upper_) + for (i = 'A'; i <= 'Z'; ++i) + ffesrc_char_match_init_[i] = FFESRC_INVALID_SYMBOL_CHAR_; + + if (ffesrc_ok_match_init_lower_) + for (i = 'a'; i <= 'z'; ++i) + ffesrc_char_match_init_[i] = toupper (i); + else + for (i = 'a'; i <= 'z'; ++i) + ffesrc_char_match_init_[i] = FFESRC_INVALID_SYMBOL_CHAR_; + + if (!ffesrc_ok_match_noninit_upper_) + for (i = 'A'; i <= 'Z'; ++i) + ffesrc_char_match_noninit_[i] = FFESRC_INVALID_SYMBOL_CHAR_; + + if (ffesrc_ok_match_noninit_lower_) + for (i = 'a'; i <= 'z'; ++i) + ffesrc_char_match_noninit_[i] = toupper (i); + else + for (i = 'a'; i <= 'z'; ++i) + ffesrc_char_match_noninit_[i] = FFESRC_INVALID_SYMBOL_CHAR_; + + if (ffe_case_source () == FFE_caseLOWER) + for (i = 'A'; i <= 'Z'; ++i) + ffesrc_char_source_[i] = tolower (i); + else if (ffe_case_source () == FFE_caseUPPER) + for (i = 'a'; i <= 'z'; ++i) + ffesrc_char_source_[i] = toupper (i); + + if (ffe_case_match () == FFE_caseLOWER) + for (i = 'A'; i <= 'Z'; ++i) + ffesrc_char_internal_init_[i] = tolower (i); + + switch (ffe_case_symbol ()) + { + case FFE_caseLOWER: + for (i = 'A'; i <= 'Z'; ++i) + { + ffesrc_bad_symbol_init_[i] = FFEBAD_SYMBOL_UPPER_CASE; + ffesrc_bad_symbol_noninit_[i] = FFEBAD_SYMBOL_UPPER_CASE; + } + break; + + case FFE_caseUPPER: + for (i = 'a'; i <= 'z'; ++i) + { + ffesrc_bad_symbol_init_[i] = FFEBAD_SYMBOL_LOWER_CASE; + ffesrc_bad_symbol_noninit_[i] = FFEBAD_SYMBOL_LOWER_CASE; + } + break; + + case FFE_caseINITCAP: + for (i = 0; i < 256; ++i) + ffesrc_bad_symbol_noninit_[i] = FFEBAD_SYMBOL_NOLOWER_INITCAP; + for (i = 'a'; i <= 'z'; ++i) + { + ffesrc_bad_symbol_init_[i] = FFEBAD_SYMBOL_LOWER_INITCAP; + ffesrc_bad_symbol_noninit_[i] = FFEBAD; + } + break; + + default: + break; + } +} + +/* Compare two strings a la strcmp, the first being a source string with its + length passed, and the second being a constant string passed + in InitialCaps form. Also, the return value is always -1, 0, or 1. */ + +int +ffesrc_strcmp_1ns2i (ffeCase mcase, const char *var, int len, + const char *str_ic) +{ + char c; + char d; + + switch (mcase) + { + case FFE_caseNONE: + for (; len > 0; --len, ++var, ++str_ic) + { + c = ffesrc_char_source (*var); /* Transform source. */ + c = ffesrc_toupper (c); /* Upcase source. */ + d = ffesrc_toupper (*str_ic); /* Upcase InitialCaps char. */ + if (c != d) + if ((d != '\0') && (c < d)) + return -1; + else + return 1; + } + break; + + case FFE_caseUPPER: + for (; len > 0; --len, ++var, ++str_ic) + { + c = ffesrc_char_source (*var); /* Transform source. */ + d = ffesrc_toupper (*str_ic); /* Transform InitialCaps char. */ + if (c != d) + if ((d != '\0') && (c < d)) + return -1; + else + return 1; + } + break; + + case FFE_caseLOWER: + for (; len > 0; --len, ++var, ++str_ic) + { + c = ffesrc_char_source (*var); /* Transform source. */ + d = ffesrc_tolower (*str_ic); /* Transform InitialCaps char. */ + if (c != d) + if ((d != '\0') && (c < d)) + return -1; + else + return 1; + } + break; + + case FFE_caseINITCAP: + for (; len > 0; --len, ++var, ++str_ic) + { + c = ffesrc_char_source (*var); /* Transform source. */ + d = *str_ic; /* No transform of InitialCaps char. */ + if (c != d) + { + c = ffesrc_toupper (c); + d = ffesrc_toupper (d); + while ((len > 0) && (c == d)) + { /* Skip past equivalent (case-ins) chars. */ + --len, ++var, ++str_ic; + if (len > 0) + c = ffesrc_toupper (*var); + d = ffesrc_toupper (*str_ic); + } + if ((d != '\0') && (c < d)) + return -1; + else + return 1; + } + } + break; + + default: + assert ("bad case value" == NULL); + return -1; + } + + if (*str_ic == '\0') + return 0; + return -1; +} + +/* Compare two strings a la strcmp, the second being a constant string passed + in both uppercase and lowercase form. If not equal, the uppercase string + is used to determine the sign of the return value. Also, the return + value is always -1, 0, or 1. */ + +int +ffesrc_strcmp_2c (ffeCase mcase, const char *var, const char *str_uc, + const char *str_lc, const char *str_ic) +{ + int i; + char c; + + switch (mcase) + { + case FFE_caseNONE: + for (; *var != '\0'; ++var, ++str_uc) + { + c = ffesrc_toupper (*var); /* Upcase source. */ + if (c != *str_uc) + if ((*str_uc != '\0') && (c < *str_uc)) + return -1; + else + return 1; + } + if (*str_uc == '\0') + return 0; + return -1; + + case FFE_caseUPPER: + i = strcmp (var, str_uc); + break; + + case FFE_caseLOWER: + i = strcmp (var, str_lc); + break; + + case FFE_caseINITCAP: + for (; *var != '\0'; ++var, ++str_ic, ++str_uc) + { + if (*var != *str_ic) + { + c = ffesrc_toupper (*var); + while ((c != '\0') && (c == *str_uc)) + { /* Skip past equivalent (case-ins) chars. */ + ++var, ++str_uc; + c = ffesrc_toupper (*var); + } + if ((*str_uc != '\0') && (c < *str_uc)) + return -1; + else + return 1; + } + } + if (*str_ic == '\0') + return 0; + return -1; + + default: + assert ("bad case value" == NULL); + return -1; + } + + if (i == 0) + return 0; + else if (i < 0) + return -1; + return 1; +} + +/* Compare two strings a la strncmp, the second being a constant string passed + in uppercase, lowercase, and InitialCaps form. If not equal, the + uppercase string is used to determine the sign of the return value. */ + +int +ffesrc_strncmp_2c (ffeCase mcase, const char *var, const char *str_uc, + const char *str_lc, const char *str_ic, int len) +{ + int i; + char c; + + switch (mcase) + { + case FFE_caseNONE: + for (; len > 0; ++var, ++str_uc, --len) + { + c = ffesrc_toupper (*var); /* Upcase source. */ + if (c != *str_uc) + if (c < *str_uc) + return -1; + else + return 1; + } + return 0; + + case FFE_caseUPPER: + i = strncmp (var, str_uc, len); + break; + + case FFE_caseLOWER: + i = strncmp (var, str_lc, len); + break; + + case FFE_caseINITCAP: + for (; len > 0; ++var, ++str_ic, ++str_uc, --len) + { + if (*var != *str_ic) + { + c = ffesrc_toupper (*var); + while ((len > 0) && (c == *str_uc)) + { /* Skip past equivalent (case-ins) chars. */ + --len, ++var, ++str_uc; + if (len > 0) + c = ffesrc_toupper (*var); + } + if ((len > 0) && (c < *str_uc)) + return -1; + else + return 1; + } + } + return 0; + + default: + assert ("bad case value" == NULL); + return -1; + } + + if (i == 0) + return 0; + else if (i < 0) + return -1; + return 1; +} diff --git a/gcc/f/src.h b/gcc/f/src.h new file mode 100644 index 000000000000..02279154d28d --- /dev/null +++ b/gcc/f/src.h @@ -0,0 +1,144 @@ +/* src.h -- Public #include File + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + src.c + + Modifications: +*/ + +/* Allow multiple inclusion to work. */ + +#ifndef _H_f_src +#define _H_f_src + +#include "bad.h" +#include "top.h" + +extern char ffesrc_toupper_[256]; +extern char ffesrc_tolower_[256]; +extern char ffesrc_char_match_init_[256]; +extern char ffesrc_char_match_noninit_[256]; +extern char ffesrc_char_source_[256]; +extern char ffesrc_char_internal_init_[256]; +extern ffebad ffesrc_bad_symbol_init_[256]; +extern ffebad ffesrc_bad_symbol_noninit_[256]; +extern bool ffesrc_check_symbol_; +extern bool ffesrc_ok_match_init_upper_; +extern bool ffesrc_ok_match_init_lower_; +extern bool ffesrc_ok_match_noninit_upper_; +extern bool ffesrc_ok_match_noninit_lower_; + +/* These C-language-syntax modifiers could avoid the match arg if gcc's + extension allowing macros to generate dynamic labels was used. They + could use the no_match arg (and the "caller's" label defs) if there + was a way to say "goto default" in a switch statement. Oh well. + + NOTE: These macro assume "case FFESRC_CASE_MATCH_[NON]INIT(...):" is used + to invoke them, and thus assume the "above" case does not fall through to + this one. This syntax was chosen to keep indenting tools working. */ + +#define FFESRC_CASE_MATCH_INIT(upper, lower, match, no_match) \ + upper: if (!ffesrc_ok_match_init_upper_) goto no_match; \ + else goto match; \ + case lower: if (!ffesrc_ok_match_init_lower_) goto no_match; \ + match + +#define FFESRC_CASE_MATCH_NONINIT(upper, lower, match, no_match) \ + upper: if (!ffesrc_ok_match_noninit_upper_) goto no_match; \ + else goto match; \ + case lower: if (!ffesrc_ok_match_noninit_lower_) goto no_match; \ + match + +/* If character is ok in a symbol name (not including intrinsic names), + returns FFEBAD, else returns something else, type ffebad. */ + +#define ffesrc_bad_char_symbol_init(c) \ + (ffesrc_bad_symbol_init_[(unsigned int) (c)]) +#define ffesrc_bad_char_symbol_noninit(c) \ + (ffesrc_bad_symbol_noninit_[(unsigned int) (c)]) + +/* Returns TRUE if character is ok in a symbol name (including + intrinsic names). Doesn't care about case settings, this is + used just for parsing (before semantic complaints about symbol- + name casing and such). One specific usage is to decide whether + an underscore is valid as the first or subsequent character in + some symbol name -- if not, an underscore is a separate token + (while lexing, for example). Note that ffesrc_is_name_init + must return TRUE for a (not necessarily proper) subset of + characters for which ffelex_is_firstnamechar returns TRUE. */ + +#define ffesrc_is_name_init(c) \ + ((isalpha ((c))) || (!(1 || ffe_is_90 ()) && ((c) == '_'))) +#define ffesrc_is_name_noninit(c) \ + ((isalnum ((c))) || (!(1 || ffe_is_90 ()) && ((c) == '_'))) + +/* Test if source-translated character matches given alphabetic character + (passed in both uppercase and lowercase, to allow for custom speedup + of compilation in environments where compile-time options aren't needed + for casing). */ + +#define ffesrc_char_match_init(c, up, low) \ + (ffesrc_char_match_init_[(unsigned int) (c)] == up) + +#define ffesrc_char_match_noninit(c, up, low) \ + (ffesrc_char_match_noninit_[(unsigned int) (c)] == up) + +/* Translate character from input-file form to source form. */ + +#define ffesrc_char_source(c) (ffesrc_char_source_[(unsigned int) (c)]) + +/* Translate internal character (upper/lower) to source form in an + initial-character context (i.e. ffesrc_char_match_init of the result + will always succeed). */ + +#define ffesrc_char_internal_init(up, low) \ + (ffesrc_char_internal_init_[(unsigned int) (up)]) + +/* Returns TRUE if a name representing a symbol should be checked for + validity according to compile-time options. That is, if it is possible + that ffesrc_bad_char_symbol(c) can return something other than FFEBAD + for any valid character in an ffelex NAME(S) token. */ + +#define ffesrc_check_symbol() ffesrc_check_symbol_ + +#define ffesrc_init_0() +void ffesrc_init_1 (void); +#define ffesrc_init_2() +#define ffesrc_init_3() +#define ffesrc_init_4() +int ffesrc_strcmp_1ns2i (ffeCase mcase, const char *var, int len, + const char *str_ic); +int ffesrc_strcmp_2c (ffeCase mcase, const char *var, const char *str_uc, + const char *str_lc, const char *str_ic); +int ffesrc_strncmp_2c (ffeCase mcase, const char *var, const char *str_uc, + const char *str_lc, const char *str_ic, int len); +#define ffesrc_terminate_0() +#define ffesrc_terminate_1() +#define ffesrc_terminate_2() +#define ffesrc_terminate_3() +#define ffesrc_terminate_4() +#define ffesrc_toupper(c) (ffesrc_toupper_[(unsigned int) (c)]) +#define ffesrc_tolower(c) (ffesrc_tolower_[(unsigned int) (c)]) + +/* End of #include file. */ + +#endif diff --git a/gcc/f/st.c b/gcc/f/st.c new file mode 100644 index 000000000000..5406acdb5a76 --- /dev/null +++ b/gcc/f/st.c @@ -0,0 +1,554 @@ +/* st.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + None + + Description: + The high-level input level to statement handling for the rest of the + FFE. ffest_first is the first state for the lexer to invoke to start + a statement. A statement normally starts with a NUMBER token (to indicate + a label def) followed by a NAME token (to indicate what kind of statement + it is), though of course the NUMBER token may be omitted. ffest_first + gathers the first NAME token and returns a state of ffest_second_, + where the trailing underscore means "internal to ffest" and thus outside + users should not depend on this. ffest_second_ then looks at the second + token in conjunction with the first, decides what possible statements are + meant, and tries each possible statement in turn, from most likely to + least likely. A successful attempt currently is recorded, and further + successful attempts by other possibilities raise an assertion error in + ffest_confirmed (this is to detect ambiguities). A failure in an + attempt is signaled by calling ffest_ffebad_start; this results in the + next token sent by ffest_save_ (the intermediary when more than one + possible statement exists) being EOS to shut down processing and the next + possibility tried. + + When all possibilities have been tried, the successful one is retried with + inhibition turned off (FALSE) as reported by ffest_is_inhibited(). If + there is no successful one, the first one is retried so the user gets to + see the error messages. + + In the future, after syntactic bugs have been reasonably shaken out and + ambiguities thus detected, the first successful possibility will be + enabled (inhibited goes FALSE) as soon as it confirms success by calling + ffest_confirmed, thus retrying the possibility will not be necessary. + + The only complication in all this is that expression handling is + happening while possibilities are inhibited. It is up to the expression + handler, conceptually, to not make any changes to its knowledge base for + variable names and so on when inhibited that cannot be undone if + the current possibility fails (shuts down via ffest_ffebad_start). In + fact, this business is handled not be ffeexpr, but by lower levels. + + ffesta functions serve only to provide information used in syntactic + processing of possible statements, and thus may not make changes to the + knowledge base for variables and such. + + ffestb functions perform the syntactic analysis for possible statements, + and thus again may not make changes to the knowledge base except under the + auspices of ffeexpr and its subordinates, changes which can be undone when + necessary. + + ffestc functions perform the semantic analysis for the chosen statement, + and thus may change the knowledge base as necessary since they are invoked + by ffestb functions only after a given statement is confirmed and + enabled. Note, however, that a few ffestc functions (identified by + their statement names rather than grammar numbers) indicate valid forms + that are, outside of any context, ambiguous, such as ELSE WHERE and + PRIVATE; these functions should make a quick decision as to what is + intended and dispatch to the appropriate specific ffestc function. + + ffestd functions actually implement statements. When called, the + statement is considered valid and is either an executable statement or + a nonexecutable statement with direct-output results. For example, CALL, + GOTO, and assignment statements pass through ffestd because they are + executable; DATA statements pass through because they map directly to the + output file (or at least might so map); ENTRY statements also pass through + because they essentially affect code generation in an immediate way; + whereas INTEGER, SAVE, and SUBROUTINE statements do not go through + ffestd functions because they merely update the knowledge base. + + Modifications: +*/ + +/* Include files. */ + +#include "proj.h" +#include "st.h" +#include "bad.h" +#include "lex.h" +#include "sta.h" +#include "stb.h" +#include "stc.h" +#include "std.h" +#include "ste.h" +#include "stp.h" +#include "str.h" +#include "sts.h" +#include "stt.h" +#include "stu.h" +#include "stv.h" +#include "stw.h" + +/* Externals defined here. */ + + +/* Simple definitions and enumerations. */ + + +/* Internal typedefs. */ + + +/* Private include files. */ + + +/* Internal structure definitions. */ + + +/* Static objects accessed by functions in this module. */ + + +/* Static functions (internal). */ + + +/* Internal macros. */ + + +/* ffest_confirmed -- Confirm current possibility as only one + + ffest_confirmed(); + + Sets the confirmation flag. During debugging for ambiguous constructs, + asserts that the confirmation flag for a previous possibility has not + yet been set. */ + +void +ffest_confirmed () +{ + ffesta_confirmed (); +} + +/* ffest_eof -- End of (non-INCLUDEd) source file + + ffest_eof(); + + Call after piping tokens through ffest_first, where the most recent + token sent through must be EOS. + + 20-Feb-91 JCB 1.1 + Put new EOF token in ffesta_tokens[0], not NULL, because too much + code expects something there for error reporting and the like. Also, + do basically the same things ffest_second and ffesta_zero do for + processing a statement (make and destroy pools, et cetera). */ + +void +ffest_eof () +{ + ffesta_eof (); +} + +/* ffest_ffebad_here_current_stmt -- ffebad_here with ptr to current stmt + + ffest_ffebad_here_current_stmt(0); + + Outsiders can call this fn if they have no more convenient place to + point to (via a token or pair of ffewhere objects) and they know a + current, useful statement is being evaluted by ffest (i.e. they are + being called from ffestb, ffestc, ffestd, ... functions). */ + +void +ffest_ffebad_here_current_stmt (ffebadIndex i) +{ + ffesta_ffebad_here_current_stmt (i); +} + +/* ffest_ffebad_here_doiter -- Calls ffebad_here with ptr to DO iter var + + ffesymbol s; + // call ffebad_start first, of course. + ffest_ffebad_here_doiter(0,s); + // call ffebad_finish afterwards, naturally. + + Searches the stack of blocks backwards for a DO loop that has s + as its iteration variable, then calls ffebad_here with pointers to + that particular reference to the variable. Crashes if the DO loop + can't be found. */ + +void +ffest_ffebad_here_doiter (ffebadIndex i, ffesymbol s) +{ + ffestc_ffebad_here_doiter (i, s); +} + +/* ffest_ffebad_start -- Start a possibly inhibited error report + + if (ffest_ffebad_start(FFEBAD_SOME_ERROR)) + { + ffebad_here, ffebad_string ...; + ffebad_finish(); + } + + Call if the error might indicate that ffest is evaluating the wrong + statement form, instead of calling ffebad_start directly. If ffest + is choosing between forms, it will return FALSE, send an EOS/SEMICOLON + token through as the next token (if the current one isn't already one + of those), and try another possible form. Otherwise, ffebad_start is + called with the argument and TRUE returned. */ + +bool +ffest_ffebad_start (ffebad errnum) +{ + return ffesta_ffebad_start (errnum); +} + +/* ffest_first -- Parse the first token in a statement + + return ffest_first; // to lexer. */ + +ffelexHandler +ffest_first (ffelexToken t) +{ + return ffesta_first (t); +} + +/* ffest_init_0 -- Initialize for entire image invocation + + ffest_init_0(); + + Call just once per invocation of the compiler (not once per invocation + of the front end). + + Gets memory for the list of possibles once and for all, since this + list never gets larger than a certain size (FFEST_maxPOSSIBLES_) + and is not particularly large. Initializes the array of pointers to + this list. Initializes the executable and nonexecutable lists. */ + +void +ffest_init_0 () +{ + ffesta_init_0 (); + ffestb_init_0 (); + ffestc_init_0 (); + ffestd_init_0 (); + ffeste_init_0 (); + ffestp_init_0 (); + ffestr_init_0 (); + ffests_init_0 (); + ffestt_init_0 (); + ffestu_init_0 (); + ffestv_init_0 (); + ffestw_init_0 (); +} + +/* ffest_init_1 -- Initialize for entire image invocation + + ffest_init_1(); + + Call just once per invocation of the compiler (not once per invocation + of the front end). + + Gets memory for the list of possibles once and for all, since this + list never gets larger than a certain size (FFEST_maxPOSSIBLES_) + and is not particularly large. Initializes the array of pointers to + this list. Initializes the executable and nonexecutable lists. */ + +void +ffest_init_1 () +{ + ffesta_init_1 (); + ffestb_init_1 (); + ffestc_init_1 (); + ffestd_init_1 (); + ffeste_init_1 (); + ffestp_init_1 (); + ffestr_init_1 (); + ffests_init_1 (); + ffestt_init_1 (); + ffestu_init_1 (); + ffestv_init_1 (); + ffestw_init_1 (); +} + +/* ffest_init_2 -- Initialize for entire image invocation + + ffest_init_2(); + + Call just once per invocation of the compiler (not once per invocation + of the front end). + + Gets memory for the list of possibles once and for all, since this + list never gets larger than a certain size (FFEST_maxPOSSIBLES_) + and is not particularly large. Initializes the array of pointers to + this list. Initializes the executable and nonexecutable lists. */ + +void +ffest_init_2 () +{ + ffesta_init_2 (); + ffestb_init_2 (); + ffestc_init_2 (); + ffestd_init_2 (); + ffeste_init_2 (); + ffestp_init_2 (); + ffestr_init_2 (); + ffests_init_2 (); + ffestt_init_2 (); + ffestu_init_2 (); + ffestv_init_2 (); + ffestw_init_2 (); +} + +/* ffest_init_3 -- Initialize for any program unit + + ffest_init_3(); */ + +void +ffest_init_3 () +{ + ffesta_init_3 (); + ffestb_init_3 (); + ffestc_init_3 (); + ffestd_init_3 (); + ffeste_init_3 (); + ffestp_init_3 (); + ffestr_init_3 (); + ffests_init_3 (); + ffestt_init_3 (); + ffestu_init_3 (); + ffestv_init_3 (); + ffestw_init_3 (); + + ffestw_display_state (); +} + +/* ffest_init_4 -- Initialize for statement functions + + ffest_init_4(); */ + +void +ffest_init_4 () +{ + ffesta_init_4 (); + ffestb_init_4 (); + ffestc_init_4 (); + ffestd_init_4 (); + ffeste_init_4 (); + ffestp_init_4 (); + ffestr_init_4 (); + ffests_init_4 (); + ffestt_init_4 (); + ffestu_init_4 (); + ffestv_init_4 (); + ffestw_init_4 (); +} + +/* Test whether ENTRY statement is valid. + + Returns TRUE if current program unit is known to be FUNCTION or SUBROUTINE. + Else returns FALSE. */ + +bool +ffest_is_entry_valid () +{ + return ffesta_is_entry_valid; +} + +/* ffest_is_inhibited -- Test whether the current possibility is inhibited + + if (!ffest_is_inhibited()) + // implement the statement. + + Just make sure the current possibility has been confirmed. If anyone + really needs to test whether the current possibility is inhibited prior + to confirming it, that indicates a need to begin statement processing + before it is certain that the given possibility is indeed the statement + to be processed. As of this writing, there does not appear to be such + a need. If there is, then when confirming a statement would normally + immediately disable the inhibition (whereas currently we leave the + confirmed statement disabled until we've tried the other possibilities, + to check for ambiguities), we must check to see if the possibility has + already tested for inhibition prior to confirmation and, if so, maintain + inhibition until the end of the statement (which may be forced right + away) and then rerun the entire statement from the beginning. Otherwise, + initial calls to ffestb functions won't have been made, but subsequent + calls (after confirmation) will, which is wrong. Of course, this all + applies only to those statements implemented via multiple calls to + ffestb, although if a statement requiring only a single ffestb call + tested for inhibition prior to confirmation, it would likely mean that + the ffestb call would be completely dropped without this mechanism. */ + +bool +ffest_is_inhibited () +{ + return ffesta_is_inhibited (); +} + +/* ffest_seen_first_exec -- Test whether first executable stmt has been seen + + if (ffest_seen_first_exec()) + // No more spec stmts can be seen. + + In a case where, say, the first statement is PARAMETER(A)=B, FALSE + will be returned while the PARAMETER statement is being run, and TRUE + will be returned if it doesn't confirm and the assignment statement + is being run. */ + +bool +ffest_seen_first_exec () +{ + return ffesta_seen_first_exec; +} + +/* Shut down current parsing possibility, but without bothering the + user with a diagnostic if we're not inhibited. */ + +void +ffest_shutdown () +{ + ffesta_shutdown (); +} + +/* ffest_sym_end_transition -- Update symbol info just before end of unit + + ffesymbol s; + ffest_sym_end_transition(s); */ + +ffesymbol +ffest_sym_end_transition (ffesymbol s) +{ + return ffestu_sym_end_transition (s); +} + +/* ffest_sym_exec_transition -- Update symbol just before first exec stmt + + ffesymbol s; + ffest_sym_exec_transition(s); */ + +ffesymbol +ffest_sym_exec_transition (ffesymbol s) +{ + return ffestu_sym_exec_transition (s); +} + +/* ffest_terminate_0 -- Terminate for entire image invocation + + ffest_terminate_0(); */ + +void +ffest_terminate_0 () +{ + ffesta_terminate_0 (); + ffestb_terminate_0 (); + ffestc_terminate_0 (); + ffestd_terminate_0 (); + ffeste_terminate_0 (); + ffestp_terminate_0 (); + ffestr_terminate_0 (); + ffests_terminate_0 (); + ffestt_terminate_0 (); + ffestu_terminate_0 (); + ffestv_terminate_0 (); + ffestw_terminate_0 (); +} + +/* ffest_terminate_1 -- Terminate for source file + + ffest_terminate_1(); */ + +void +ffest_terminate_1 () +{ + ffesta_terminate_1 (); + ffestb_terminate_1 (); + ffestc_terminate_1 (); + ffestd_terminate_1 (); + ffeste_terminate_1 (); + ffestp_terminate_1 (); + ffestr_terminate_1 (); + ffests_terminate_1 (); + ffestt_terminate_1 (); + ffestu_terminate_1 (); + ffestv_terminate_1 (); + ffestw_terminate_1 (); +} + +/* ffest_terminate_2 -- Terminate for outer program unit + + ffest_terminate_2(); */ + +void +ffest_terminate_2 () +{ + ffesta_terminate_2 (); + ffestb_terminate_2 (); + ffestc_terminate_2 (); + ffestd_terminate_2 (); + ffeste_terminate_2 (); + ffestp_terminate_2 (); + ffestr_terminate_2 (); + ffests_terminate_2 (); + ffestt_terminate_2 (); + ffestu_terminate_2 (); + ffestv_terminate_2 (); + ffestw_terminate_2 (); +} + +/* ffest_terminate_3 -- Terminate for any program unit + + ffest_terminate_3(); */ + +void +ffest_terminate_3 () +{ + ffesta_terminate_3 (); + ffestb_terminate_3 (); + ffestc_terminate_3 (); + ffestd_terminate_3 (); + ffeste_terminate_3 (); + ffestp_terminate_3 (); + ffestr_terminate_3 (); + ffests_terminate_3 (); + ffestt_terminate_3 (); + ffestu_terminate_3 (); + ffestv_terminate_3 (); + ffestw_terminate_3 (); +} + +/* ffest_terminate_4 -- Terminate for statement functions + + ffest_terminate_4(); */ + +void +ffest_terminate_4 () +{ + ffesta_terminate_4 (); + ffestb_terminate_4 (); + ffestc_terminate_4 (); + ffestd_terminate_4 (); + ffeste_terminate_4 (); + ffestp_terminate_4 (); + ffestr_terminate_4 (); + ffests_terminate_4 (); + ffestt_terminate_4 (); + ffestu_terminate_4 (); + ffestv_terminate_4 (); + ffestw_terminate_4 (); +} diff --git a/gcc/f/st.h b/gcc/f/st.h new file mode 100644 index 000000000000..d762f6c92536 --- /dev/null +++ b/gcc/f/st.h @@ -0,0 +1,81 @@ +/* st.h -- Public #include File (module.h template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + st.c + + Modifications: +*/ + +/* Allow multiple inclusion to work. */ + +#ifndef _H_f_st +#define _H_f_st + +/* Simple definitions and enumerations. */ + + +/* Typedefs. */ + + +/* Include files needed by this one. */ + +#include "bad.h" +#include "lex.h" +#include "symbol.h" + +/* Structure definitions. */ + + +/* Global objects accessed by users of this module. */ + + +/* Declare functions with prototypes. */ + +void ffest_confirmed (void); +void ffest_eof (void); +bool ffest_ffebad_start (ffebad errnum); +void ffest_ffebad_here_current_stmt (ffebadIndex i); +void ffest_ffebad_here_doiter (ffebadIndex i, ffesymbol s); +ffelexHandler ffest_first (ffelexToken t); +void ffest_init_0 (void); +void ffest_init_1 (void); +void ffest_init_2 (void); +void ffest_init_3 (void); +void ffest_init_4 (void); +bool ffest_is_entry_valid (void); +bool ffest_is_inhibited (void); +bool ffest_seen_first_exec (void); +void ffest_shutdown (void); +ffesymbol ffest_sym_end_transition (ffesymbol s); +ffesymbol ffest_sym_exec_transition (ffesymbol s); +void ffest_terminate_0 (void); +void ffest_terminate_1 (void); +void ffest_terminate_2 (void); +void ffest_terminate_3 (void); +void ffest_terminate_4 (void); + +/* Define macros. */ + + +/* End of #include file. */ + +#endif diff --git a/gcc/f/sta.c b/gcc/f/sta.c new file mode 100644 index 000000000000..328bfd0f662e --- /dev/null +++ b/gcc/f/sta.c @@ -0,0 +1,1993 @@ +/* sta.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995-1997 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + None + + Description: + Analyzes the first two tokens, figures out what statements are + possible, tries parsing the possible statements by calling on + the ffestb functions. + + Modifications: +*/ + +/* Include files. */ + +#include "proj.h" +#include "sta.h" +#include "bad.h" +#include "implic.h" +#include "lex.h" +#include "malloc.h" +#include "stb.h" +#include "stc.h" +#include "std.h" +#include "str.h" +#include "storag.h" +#include "symbol.h" + +/* Externals defined here. */ + +ffelexToken ffesta_tokens[FFESTA_tokensMAX]; /* For use by a possible. */ +ffestrFirst ffesta_first_kw; /* First NAME(S) looked up. */ +ffestrSecond ffesta_second_kw; /* Second NAME(S) looked up. */ +mallocPool ffesta_output_pool; /* Pool for results of stmt handling. */ +mallocPool ffesta_scratch_pool; /* Pool for stmt scratch handling. */ +ffelexToken ffesta_construct_name; +ffelexToken ffesta_label_token; /* Pending label stuff. */ +bool ffesta_seen_first_exec; +bool ffesta_is_entry_valid = FALSE; /* TRUE only in SUBROUTINE/FUNCTION. */ +bool ffesta_line_has_semicolons = FALSE; + +/* Simple definitions and enumerations. */ + +#define FFESTA_ABORT_ON_CONFIRM_ 1 /* 0=slow, tested way; 1=faster way + that might not always work. Here's + the old description of what used + to not work with ==1: (try + "CONTINUE\10 + FORMAT('hi',I11)\END"). Problem + is that the "topology" of the + confirmed stmt's tokens with + regard to CHARACTER, HOLLERITH, + NAME/NAMES/NUMBER tokens (like hex + numbers), isn't traced if we abort + early, then other stmts might get + their grubby hands on those + unprocessed tokens and commit them + improperly. Ideal fix is to rerun + the confirmed stmt and forget the + rest. */ + +#define FFESTA_maxPOSSIBLES_ 8/* Never more than this # of possibles. */ + +/* Internal typedefs. */ + +typedef struct _ffesta_possible_ *ffestaPossible_; + +/* Private include files. */ + + +/* Internal structure definitions. */ + +struct _ffesta_possible_ + { + ffestaPossible_ next; + ffestaPossible_ previous; + ffelexHandler handler; + bool named; + }; + +struct _ffesta_possible_root_ + { + ffestaPossible_ first; + ffestaPossible_ last; + ffelexHandler nil; + }; + +/* Static objects accessed by functions in this module. */ + +static bool ffesta_is_inhibited_ = FALSE; +static ffelexToken ffesta_token_0_; /* For use by ffest possibility + handling. */ +static ffestaPossible_ ffesta_possibles_[FFESTA_maxPOSSIBLES_]; +static int ffesta_num_possibles_ = 0; /* Number of possibilities. */ +static struct _ffesta_possible_root_ ffesta_possible_nonexecs_; +static struct _ffesta_possible_root_ ffesta_possible_execs_; +static ffestaPossible_ ffesta_current_possible_; +static ffelexHandler ffesta_current_handler_; +static bool ffesta_confirmed_current_ = FALSE; +static bool ffesta_confirmed_other_ = FALSE; +static ffestaPossible_ ffesta_confirmed_possible_; +static bool ffesta_current_shutdown_ = FALSE; +#if !FFESTA_ABORT_ON_CONFIRM_ +static bool ffesta_is_two_into_statement_ = FALSE; /* For IF, WHERE stmts. */ +static ffelexToken ffesta_twotokens_1_; /* For IF, WHERE stmts. */ +static ffelexToken ffesta_twotokens_2_; /* For IF, WHERE stmts. */ +#endif +static ffestaPooldisp ffesta_outpooldisp_; /* After statement dealt + with. */ +static bool ffesta_inhibit_confirmation_ = FALSE; + +/* Static functions (internal). */ + +static void ffesta_add_possible_ (ffelexHandler fn, bool exec, bool named); +static bool ffesta_inhibited_exec_transition_ (void); +static void ffesta_reset_possibles_ (void); +static ffelexHandler ffesta_save_ (ffelexToken t); +static ffelexHandler ffesta_second_ (ffelexToken t); +#if !FFESTA_ABORT_ON_CONFIRM_ +static ffelexHandler ffesta_send_two_ (ffelexToken t); +#endif + +/* Internal macros. */ + +#define ffesta_add_possible_exec_(fn) (ffesta_add_possible_ (fn, TRUE, TRUE)) +#define ffesta_add_possible_nonexec_(fn) (ffesta_add_possible_ (fn, FALSE, TRUE)) +#define ffesta_add_possible_unnamed_exec_(fn) (ffesta_add_possible_ (fn, TRUE, FALSE)) +#define ffesta_add_possible_unnamed_nonexec_(fn) (ffesta_add_possible_ (fn, FALSE, FALSE)) + +/* Add possible statement to appropriate list. */ + +static void +ffesta_add_possible_ (ffelexHandler fn, bool exec, bool named) +{ + ffestaPossible_ p; + + assert (ffesta_num_possibles_ < FFESTA_maxPOSSIBLES_); + + p = ffesta_possibles_[ffesta_num_possibles_++]; + + if (exec) + { + p->next = (ffestaPossible_) &ffesta_possible_execs_.first; + p->previous = ffesta_possible_execs_.last; + } + else + { + p->next = (ffestaPossible_) &ffesta_possible_nonexecs_.first; + p->previous = ffesta_possible_nonexecs_.last; + } + p->next->previous = p; + p->previous->next = p; + + p->handler = fn; + p->named = named; +} + +/* ffesta_inhibited_exec_transition_ -- Do exec transition while inhibited + + if (!ffesta_inhibited_exec_transition_()) // couldn't transition... + + Invokes ffestc_exec_transition, but first enables ffebad and ffesta and + afterwards disables them again. Then returns the result of the + invocation of ffestc_exec_transition. */ + +static bool +ffesta_inhibited_exec_transition_ () +{ + bool result; + + assert (ffebad_inhibit ()); + assert (ffesta_is_inhibited_); + + ffebad_set_inhibit (FALSE); + ffesta_is_inhibited_ = FALSE; + + result = ffestc_exec_transition (); + + ffebad_set_inhibit (TRUE); + ffesta_is_inhibited_ = TRUE; + + return result; +} + +/* ffesta_reset_possibles_ -- Reset (clear) lists of possible statements + + ffesta_reset_possibles_(); + + Clears the lists of executable and nonexecutable statements. */ + +static void +ffesta_reset_possibles_ () +{ + ffesta_num_possibles_ = 0; + + ffesta_possible_execs_.first = ffesta_possible_execs_.last + = (ffestaPossible_) &ffesta_possible_execs_.first; + ffesta_possible_nonexecs_.first = ffesta_possible_nonexecs_.last + = (ffestaPossible_) &ffesta_possible_nonexecs_.first; +} + +/* ffesta_save_ -- Save token on list, pass thru to current handler + + return ffesta_save_; // to lexer. + + Receives a token from the lexer. Saves it in the list of tokens. Calls + the current handler with the token. + + If no shutdown error occurred (via + ffest_ffebad_start), then if the token was EOS or SEMICOLON, mark the + current possible as successful and confirmed but try the next possible + anyway until ambiguities in the form handling are ironed out. */ + +static ffelexHandler +ffesta_save_ (ffelexToken t) +{ + static ffelexToken *saved_tokens = NULL; /* A variable-sized array. */ + static unsigned int num_saved_tokens = 0; /* Number currently saved. */ + static unsigned int max_saved_tokens = 0; /* Maximum to be saved. */ + unsigned int toknum; /* Index into saved_tokens array. */ + ffelexToken eos; /* EOS created on-the-fly for shutdown + purposes. */ + ffelexToken t2; /* Another temporary token (no intersect with + eos, btw). */ + + /* Save the current token. */ + + if (saved_tokens == NULL) + { + saved_tokens + = (ffelexToken *) malloc_new_ksr (malloc_pool_image (), + "FFEST Saved Tokens", + (max_saved_tokens = 8) * sizeof (ffelexToken)); + /* Start off with 8. */ + } + else if (num_saved_tokens >= max_saved_tokens) + { + toknum = max_saved_tokens; + max_saved_tokens <<= 1; /* Multiply by two. */ + assert (max_saved_tokens > toknum); + saved_tokens + = (ffelexToken *) malloc_resize_ksr (malloc_pool_image (), + saved_tokens, + max_saved_tokens * sizeof (ffelexToken), + toknum * sizeof (ffelexToken)); + } + + *(saved_tokens + num_saved_tokens++) = ffelex_token_use (t); + + /* Transmit the current token to the current handler. */ + + ffesta_current_handler_ = (ffelexHandler) (*ffesta_current_handler_) (t); + + /* See if this possible has been shut down, or confirmed in which case we + might as well shut it down anyway to save time. */ + + if ((ffesta_current_shutdown_ || (FFESTA_ABORT_ON_CONFIRM_ + && ffesta_confirmed_current_)) + && !ffelex_expecting_character ()) + { + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + + default: + eos = ffelex_token_new_eos (ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffesta_inhibit_confirmation_ = ffesta_current_shutdown_; + (*ffesta_current_handler_) (eos); + ffesta_inhibit_confirmation_ = FALSE; + ffelex_token_kill (eos); + break; + } + } + else + { + + /* If this is an EOS or SEMICOLON token, switch to next handler, else + return self as next handler for lexer. */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + + default: + return (ffelexHandler) ffesta_save_; + } + } + + next_handler: /* :::::::::::::::::::: */ + + /* Note that a shutdown also happens after seeing the first two tokens + after "IF (expr)" or "WHERE (expr)" where a statement follows, even + though there is no error. This causes the IF or WHERE form to be + implemented first before ffest_first is called for the first token in + the following statement. */ + + if (ffesta_current_shutdown_) + ffesta_current_shutdown_ = FALSE; /* Only after sending EOS! */ + else + assert (ffesta_confirmed_current_); + + if (ffesta_confirmed_current_) + { + ffesta_confirmed_current_ = FALSE; + ffesta_confirmed_other_ = TRUE; + } + + /* Pick next handler. */ + + ffesta_current_possible_ = ffesta_current_possible_->next; + ffesta_current_handler_ = ffesta_current_possible_->handler; + if (ffesta_current_handler_ == NULL) + { /* No handler in this list, try exec list if + not tried yet. */ + if (ffesta_current_possible_ + == (ffestaPossible_) &ffesta_possible_nonexecs_) + { + ffesta_current_possible_ = ffesta_possible_execs_.first; + ffesta_current_handler_ = ffesta_current_possible_->handler; + } + if ((ffesta_current_handler_ == NULL) + || (!ffesta_seen_first_exec + && ((ffesta_confirmed_possible_ != NULL) + || !ffesta_inhibited_exec_transition_ ()))) + /* Don't run execs if: (decoding the "if" ^^^ up here ^^^) - we + have no exec handler available, or - we haven't seen the first + executable statement yet, and - we've confirmed a nonexec + (otherwise even a nonexec would cause a transition), or - a + nonexec-to-exec transition can't be made at the statement context + level (as in an executable statement in the middle of a STRUCTURE + definition); if it can be made, ffestc_exec_transition makes the + corresponding transition at the statement state level so + specification statements are no longer accepted following an + unrecognized statement. (Note: it is valid for f_e_t_ to decide + to always return TRUE by "shrieking" away the statement state + stack until a transitionable state is reached. Or it can leave + the stack as is and return FALSE.) + + If we decide not to run execs, enter this block to rerun the + confirmed statement, if any. */ + { /* At end of both lists! Pick confirmed or + first possible. */ + ffebad_set_inhibit (FALSE); + ffesta_is_inhibited_ = FALSE; + ffesta_confirmed_other_ = FALSE; + ffesta_tokens[0] = ffesta_token_0_; + if (ffesta_confirmed_possible_ == NULL) + { /* No confirmed success, just use first + named possible, or first possible if + no named possibles. */ + ffestaPossible_ possible = ffesta_possible_nonexecs_.first; + ffestaPossible_ first = NULL; + ffestaPossible_ first_named = NULL; + ffestaPossible_ first_exec = NULL; + + for (;;) + { + if (possible->handler == NULL) + { + if (possible == (ffestaPossible_) &ffesta_possible_nonexecs_) + { + possible = first_exec = ffesta_possible_execs_.first; + continue; + } + else + break; + } + if (first == NULL) + first = possible; + if (possible->named + && (first_named == NULL)) + first_named = possible; + + possible = possible->next; + } + + if (first_named != NULL) + ffesta_current_possible_ = first_named; + else if (ffesta_seen_first_exec + && (first_exec != NULL)) + ffesta_current_possible_ = first_exec; + else + ffesta_current_possible_ = first; + + ffesta_current_handler_ = ffesta_current_possible_->handler; + assert (ffesta_current_handler_ != NULL); + } + else + { /* Confirmed success, use it. */ + ffesta_current_possible_ = ffesta_confirmed_possible_; + ffesta_current_handler_ = ffesta_confirmed_possible_->handler; + } + ffesta_reset_possibles_ (); + } + else + { /* Switching from [empty?] list of nonexecs + to nonempty list of execs at this point. */ + ffesta_tokens[0] = ffelex_token_use (ffesta_token_0_); + ffesymbol_set_retractable (ffesta_scratch_pool); + } + } + else + { + ffesta_tokens[0] = ffelex_token_use (ffesta_token_0_); + ffesymbol_set_retractable (ffesta_scratch_pool); + } + + /* Send saved tokens to current handler until either shut down or all + tokens sent. */ + + for (toknum = 0; toknum < num_saved_tokens; ++toknum) + { + t = *(saved_tokens + toknum); + switch (ffelex_token_type (t)) + { + case FFELEX_typeCHARACTER: + ffelex_set_expecting_hollerith (0, '\0', + ffewhere_line_unknown (), + ffewhere_column_unknown ()); + ffesta_current_handler_ + = (ffelexHandler) (*ffesta_current_handler_) (t); + break; + + case FFELEX_typeNAMES: + if (ffelex_is_names_expected ()) + ffesta_current_handler_ + = (ffelexHandler) (*ffesta_current_handler_) (t); + else + { + t2 = ffelex_token_name_from_names (t, 0, 0); + ffesta_current_handler_ + = (ffelexHandler) (*ffesta_current_handler_) (t2); + ffelex_token_kill (t2); + } + break; + + default: + ffesta_current_handler_ + = (ffelexHandler) (*ffesta_current_handler_) (t); + break; + } + + if (!ffesta_is_inhibited_) + ffelex_token_kill (t); /* Won't need this any more. */ + + /* See if this possible has been shut down. */ + + else if ((ffesta_current_shutdown_ || (FFESTA_ABORT_ON_CONFIRM_ + && ffesta_confirmed_current_)) + && !ffelex_expecting_character ()) + { + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + + default: + eos = ffelex_token_new_eos (ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffesta_inhibit_confirmation_ = ffesta_current_shutdown_; + (*ffesta_current_handler_) (eos); + ffesta_inhibit_confirmation_ = FALSE; + ffelex_token_kill (eos); + break; + } + goto next_handler; /* :::::::::::::::::::: */ + } + } + + /* Finished sending all the tokens so far. If still trying possibilities, + then if we've just sent an EOS or SEMICOLON token through, go to the + next handler. Otherwise, return self so we can gather and process more + tokens. */ + + if (ffesta_is_inhibited_) + { + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + goto next_handler; /* :::::::::::::::::::: */ + + default: +#if FFESTA_ABORT_ON_CONFIRM_ + assert (!ffesta_confirmed_other_); /* Catch ambiguities. */ +#endif + return (ffelexHandler) ffesta_save_; + } + } + + /* This was the one final possibility, uninhibited, so send the final + handler it sent. */ + + num_saved_tokens = 0; +#if !FFESTA_ABORT_ON_CONFIRM_ + if (ffesta_is_two_into_statement_) + { /* End of the line for the previous two + tokens, resurrect them. */ + ffelexHandler next; + + ffesta_is_two_into_statement_ = FALSE; + next = (ffelexHandler) ffesta_first (ffesta_twotokens_1_); + ffelex_token_kill (ffesta_twotokens_1_); + next = (ffelexHandler) (*next) (ffesta_twotokens_2_); + ffelex_token_kill (ffesta_twotokens_2_); + return (ffelexHandler) next; + } +#endif + + assert (ffesta_current_handler_ != NULL); + return (ffelexHandler) ffesta_current_handler_; +} + +/* ffesta_second_ -- Parse the token after a NAME/NAMES in a statement + + return ffesta_second_; // to lexer. + + The second token cannot be a NAMES, since the first token is a NAME or + NAMES. If the second token is a NAME, look up its name in the list of + second names for use by whoever needs it. + + Then make a list of all the possible statements this could be, based on + looking at the first two tokens. Two lists of possible statements are + created, one consisting of nonexecutable statements, the other consisting + of executable statements. + + If the total number of possibilities is one, just fire up that + possibility by calling its handler function, passing the first two + tokens through it and so on. + + Otherwise, start up a process whereby tokens are passed to the first + possibility on the list until EOS or SEMICOLON is reached or an error + is detected. But inhibit any actual reporting of errors; just record + their existence in the list. If EOS or SEMICOLON is reached with no + errors (other than non-form errors happening downstream, such as an + overflowing value for an integer or a GOTO statement identifying a label + on a FORMAT statement), then that is the only possible statement. Rerun + the statement with error-reporting turned on if any non-form errors were + generated, otherwise just use its results, then erase the list of tokens + memorized during the search process. If a form error occurs, immediately + cancel that possibility by sending EOS as the next token, remember the + error code for that possibility, and try the next possibility on the list, + first sending it the list of tokens memorized while handling the first + possibility, then continuing on as before. + + Ultimately, either the end of the list of possibilities will be reached + without any successful forms being detected, in which case we pick one + based on hueristics (usually the first possibility) and rerun it with + error reporting turned on using the list of memorized tokens so the user + sees the error, or one of the possibilities will effectively succeed. */ + +static ffelexHandler +ffesta_second_ (ffelexToken t) +{ + ffelexHandler next; + ffesymbol s; + + assert (ffelex_token_type (t) != FFELEX_typeNAMES); + + if (ffelex_token_type (t) == FFELEX_typeNAME) + ffesta_second_kw = ffestr_second (t); + + /* Here we use switch on the first keyword name and handle each possible + recognizable name by looking at the second token, and building the list + of possible names accordingly. For now, just put every possible + statement on the list for ambiguity checking. */ + + switch (ffesta_first_kw) + { +#if FFESTR_VXT + case FFESTR_firstACCEPT: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V019); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstALLOCATABLE: + ffestb_args.dimlist.len = FFESTR_firstlALLOCATABLE; + ffestb_args.dimlist.badname = "ALLOCATABLE"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dimlist); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstALLOCATE: + ffestb_args.heap.len = FFESTR_firstlALLOCATE; + ffestb_args.heap.badname = "ALLOCATE"; + ffestb_args.heap.ctx = FFEEXPR_contextALLOCATE; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_heap); + break; +#endif + + case FFESTR_firstASSIGN: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R838); + break; + + case FFESTR_firstBACKSPACE: + ffestb_args.beru.len = FFESTR_firstlBACKSPACE; + ffestb_args.beru.badname = "BACKSPACE"; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_beru); + break; + + case FFESTR_firstBLOCK: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_block); + break; + + case FFESTR_firstBLOCKDATA: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_blockdata); + break; + + case FFESTR_firstBYTE: + ffestb_args.decl.len = FFESTR_firstlBYTE; + ffestb_args.decl.type = FFESTP_typeBYTE; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype); + break; + + case FFESTR_firstCALL: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R1212); + break; + + case FFESTR_firstCASE: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R810); + break; + + case FFESTR_firstCHRCTR: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_chartype); + break; + + case FFESTR_firstCLOSE: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R907); + break; + + case FFESTR_firstCOMMON: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R547); + break; + + case FFESTR_firstCMPLX: + ffestb_args.decl.len = FFESTR_firstlCMPLX; + ffestb_args.decl.type = FFESTP_typeCOMPLEX; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype); + break; + +#if FFESTR_F90 + case FFESTR_firstCONTAINS: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R1228); + break; +#endif + + case FFESTR_firstCONTINUE: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R841); + break; + + case FFESTR_firstCYCLE: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R834); + break; + + case FFESTR_firstDATA: + if (ffe_is_pedantic_not_90 ()) + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R528); + else + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R528); + break; + +#if FFESTR_F90 + case FFESTR_firstDEALLOCATE: + ffestb_args.heap.len = FFESTR_firstlDEALLOCATE; + ffestb_args.heap.badname = "DEALLOCATE"; + ffestb_args.heap.ctx = FFEEXPR_contextDEALLOCATE; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_heap); + break; +#endif + +#if FFESTR_VXT + case FFESTR_firstDECODE: + ffestb_args.vxtcode.len = FFESTR_firstlDECODE; + ffestb_args.vxtcode.badname = "DECODE"; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_vxtcode); + break; +#endif + +#if FFESTR_VXT + case FFESTR_firstDEFINEFILE: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V025); + break; + + case FFESTR_firstDELETE: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V021); + break; +#endif + case FFESTR_firstDIMENSION: + ffestb_args.R524.len = FFESTR_firstlDIMENSION; + ffestb_args.R524.badname = "DIMENSION"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R524); + break; + + case FFESTR_firstDO: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_do); + break; + + case FFESTR_firstDBL: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_double); + break; + + case FFESTR_firstDBLCMPLX: + ffestb_args.decl.len = FFESTR_firstlDBLCMPLX; + ffestb_args.decl.type = FFESTP_typeDBLCMPLX; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_dbltype); + break; + + case FFESTR_firstDBLPRCSN: + ffestb_args.decl.len = FFESTR_firstlDBLPRCSN; + ffestb_args.decl.type = FFESTP_typeDBLPRCSN; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_dbltype); + break; + + case FFESTR_firstDOWHILE: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_dowhile); + break; + + case FFESTR_firstELSE: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_else); + break; + + case FFESTR_firstELSEIF: + ffestb_args.elsexyz.second = FFESTR_secondIF; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_elsexyz); + break; + +#if FFESTR_F90 + case FFESTR_firstELSEWHERE: + ffestb_args.elsexyz.second = FFESTR_secondWHERE; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_elsexyz); + break; +#endif + +#if FFESTR_VXT + case FFESTR_firstENCODE: + ffestb_args.vxtcode.len = FFESTR_firstlENCODE; + ffestb_args.vxtcode.badname = "ENCODE"; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_vxtcode); + break; +#endif + + case FFESTR_firstEND: + if ((ffelex_token_type (ffesta_token_0_) == FFELEX_typeNAMES) + || (ffelex_token_type (t) != FFELEX_typeNAME)) + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_end); + else + { + switch (ffesta_second_kw) + { + case FFESTR_secondBLOCK: + case FFESTR_secondBLOCKDATA: + case FFESTR_secondDO: + case FFESTR_secondFILE: + case FFESTR_secondFUNCTION: + case FFESTR_secondIF: +#if FFESTR_F90 + case FFESTR_secondMODULE: +#endif + case FFESTR_secondPROGRAM: + case FFESTR_secondSELECT: + case FFESTR_secondSUBROUTINE: +#if FFESTR_F90 + case FFESTR_secondWHERE: +#endif + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_end); + break; + + default: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_end); + break; + } + } + break; + + case FFESTR_firstENDBLOCK: + ffestb_args.endxyz.len = FFESTR_firstlENDBLOCK; + ffestb_args.endxyz.second = FFESTR_secondBLOCK; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; + + case FFESTR_firstENDBLOCKDATA: + ffestb_args.endxyz.len = FFESTR_firstlENDBLOCKDATA; + ffestb_args.endxyz.second = FFESTR_secondBLOCKDATA; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; + + case FFESTR_firstENDDO: + ffestb_args.endxyz.len = FFESTR_firstlENDDO; + ffestb_args.endxyz.second = FFESTR_secondDO; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; + + case FFESTR_firstENDFILE: + ffestb_args.beru.len = FFESTR_firstlENDFILE; + ffestb_args.beru.badname = "ENDFILE"; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_beru); + break; + + case FFESTR_firstENDFUNCTION: + ffestb_args.endxyz.len = FFESTR_firstlENDFUNCTION; + ffestb_args.endxyz.second = FFESTR_secondFUNCTION; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; + + case FFESTR_firstENDIF: + ffestb_args.endxyz.len = FFESTR_firstlENDIF; + ffestb_args.endxyz.second = FFESTR_secondIF; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; + +#if FFESTR_F90 + case FFESTR_firstENDINTERFACE: + ffestb_args.endxyz.len = FFESTR_firstlENDINTERFACE; + ffestb_args.endxyz.second = FFESTR_secondINTERFACE; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_endxyz); + break; +#endif + +#if FFESTR_VXT + case FFESTR_firstENDMAP: + ffestb_args.endxyz.len = FFESTR_firstlENDMAP; + ffestb_args.endxyz.second = FFESTR_secondMAP; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_endxyz); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstENDMODULE: + ffestb_args.endxyz.len = FFESTR_firstlENDMODULE; + ffestb_args.endxyz.second = FFESTR_secondMODULE; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; +#endif + + case FFESTR_firstENDPROGRAM: + ffestb_args.endxyz.len = FFESTR_firstlENDPROGRAM; + ffestb_args.endxyz.second = FFESTR_secondPROGRAM; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; + + case FFESTR_firstENDSELECT: + ffestb_args.endxyz.len = FFESTR_firstlENDSELECT; + ffestb_args.endxyz.second = FFESTR_secondSELECT; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; + +#if FFESTR_VXT + case FFESTR_firstENDSTRUCTURE: + ffestb_args.endxyz.len = FFESTR_firstlENDSTRUCTURE; + ffestb_args.endxyz.second = FFESTR_secondSTRUCTURE; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_endxyz); + break; +#endif + + case FFESTR_firstENDSUBROUTINE: + ffestb_args.endxyz.len = FFESTR_firstlENDSUBROUTINE; + ffestb_args.endxyz.second = FFESTR_secondSUBROUTINE; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; + +#if FFESTR_F90 + case FFESTR_firstENDTYPE: + ffestb_args.endxyz.len = FFESTR_firstlENDTYPE; + ffestb_args.endxyz.second = FFESTR_secondTYPE; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_endxyz); + break; +#endif + +#if FFESTR_VXT + case FFESTR_firstENDUNION: + ffestb_args.endxyz.len = FFESTR_firstlENDUNION; + ffestb_args.endxyz.second = FFESTR_secondUNION; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_endxyz); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstENDWHERE: + ffestb_args.endxyz.len = FFESTR_firstlENDWHERE; + ffestb_args.endxyz.second = FFESTR_secondWHERE; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz); + break; +#endif + + case FFESTR_firstENTRY: + ffestb_args.dummy.len = FFESTR_firstlENTRY; + ffestb_args.dummy.badname = "ENTRY"; + ffestb_args.dummy.is_subr = ffestc_is_entry_in_subr (); + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dummy); + break; + + case FFESTR_firstEQUIVALENCE: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R544); + break; + + case FFESTR_firstEXIT: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R835); + break; + + case FFESTR_firstEXTERNAL: + ffestb_args.varlist.len = FFESTR_firstlEXTERNAL; + ffestb_args.varlist.badname = "EXTERNAL"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist); + break; + +#if FFESTR_VXT + case FFESTR_firstFIND: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V026); + break; +#endif + + /* WARNING: don't put anything that might cause an item to precede + FORMAT in the list of possible statements (it's added below) without + making sure FORMAT still is first. It has to run with + ffelex_set_names_pure(TRUE), to make sure the lexer delivers NAMES + tokens. */ + + case FFESTR_firstFORMAT: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R1001); + break; + + case FFESTR_firstFUNCTION: + ffestb_args.dummy.len = FFESTR_firstlFUNCTION; + ffestb_args.dummy.badname = "FUNCTION"; + ffestb_args.dummy.is_subr = FALSE; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dummy); + break; + + case FFESTR_firstGOTO: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_goto); + break; + + case FFESTR_firstIF: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_if); + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R840); + break; + + case FFESTR_firstIMPLICIT: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_R539); + break; + + case FFESTR_firstINCLUDE: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_S3P4); + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + case FFELEX_typeNAME: + case FFELEX_typeAPOSTROPHE: + case FFELEX_typeQUOTE: + break; + + default: + break; + } + break; + + case FFESTR_firstINQUIRE: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R923); + break; + + case FFESTR_firstINTGR: + ffestb_args.decl.len = FFESTR_firstlINTGR; + ffestb_args.decl.type = FFESTP_typeINTEGER; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype); + break; + +#if FFESTR_F90 + case FFESTR_firstINTENT: + ffestb_args.varlist.len = FFESTR_firstlINTENT; + ffestb_args.varlist.badname = "INTENT"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstINTERFACE: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R1202); + break; +#endif + + case FFESTR_firstINTRINSIC: + ffestb_args.varlist.len = FFESTR_firstlINTRINSIC; + ffestb_args.varlist.badname = "INTRINSIC"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist); + break; + + case FFESTR_firstLGCL: + ffestb_args.decl.len = FFESTR_firstlLGCL; + ffestb_args.decl.type = FFESTP_typeLOGICAL; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype); + break; + +#if FFESTR_VXT + case FFESTR_firstMAP: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V012); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstMODULE: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_module); + break; +#endif + + case FFESTR_firstNAMELIST: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R542); + break; + +#if FFESTR_F90 + case FFESTR_firstNULLIFY: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R624); + break; +#endif + + case FFESTR_firstOPEN: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R904); + break; + +#if FFESTR_F90 + case FFESTR_firstOPTIONAL: + ffestb_args.varlist.len = FFESTR_firstlOPTIONAL; + ffestb_args.varlist.badname = "OPTIONAL"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist); + break; +#endif + + case FFESTR_firstPARAMETER: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R537); + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V027); + break; + + case FFESTR_firstPAUSE: + ffestb_args.halt.len = FFESTR_firstlPAUSE; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_halt); + break; + +#if FFESTR_F90 + case FFESTR_firstPOINTER: + ffestb_args.dimlist.len = FFESTR_firstlPOINTER; + ffestb_args.dimlist.badname = "POINTER"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dimlist); + break; +#endif + + case FFESTR_firstPRINT: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R911); + break; + +#if HARD_F90 + case FFESTR_firstPRIVATE: + ffestb_args.varlist.len = FFESTR_firstlPRIVATE; + ffestb_args.varlist.badname = "ACCESS"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist); + break; +#endif + + case FFESTR_firstPROGRAM: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R1102); + break; + +#if HARD_F90 + case FFESTR_firstPUBLIC: + ffestb_args.varlist.len = FFESTR_firstlPUBLIC; + ffestb_args.varlist.badname = "ACCESS"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist); + break; +#endif + + case FFESTR_firstREAD: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R909); + break; + + case FFESTR_firstREAL: + ffestb_args.decl.len = FFESTR_firstlREAL; + ffestb_args.decl.type = FFESTP_typeREAL; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype); + break; + +#if FFESTR_VXT + case FFESTR_firstRECORD: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V016); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstRECURSIVE: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_recursive); + break; +#endif + + case FFESTR_firstRETURN: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R1227); + break; + + case FFESTR_firstREWIND: + ffestb_args.beru.len = FFESTR_firstlREWIND; + ffestb_args.beru.badname = "REWIND"; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_beru); + break; + +#if FFESTR_VXT + case FFESTR_firstREWRITE: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V018); + break; +#endif + + case FFESTR_firstSAVE: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R522); + break; + + case FFESTR_firstSELECT: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R809); + break; + + case FFESTR_firstSELECTCASE: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R809); + break; + +#if HARD_F90 + case FFESTR_firstSEQUENCE: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R423B); + break; +#endif + + case FFESTR_firstSTOP: + ffestb_args.halt.len = FFESTR_firstlSTOP; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_halt); + break; + +#if FFESTR_VXT + case FFESTR_firstSTRUCTURE: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V003); + break; +#endif + + case FFESTR_firstSUBROUTINE: + ffestb_args.dummy.len = FFESTR_firstlSUBROUTINE; + ffestb_args.dummy.badname = "SUBROUTINE"; + ffestb_args.dummy.is_subr = TRUE; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dummy); + break; + +#if FFESTR_F90 + case FFESTR_firstTARGET: + ffestb_args.dimlist.len = FFESTR_firstlTARGET; + ffestb_args.dimlist.badname = "TARGET"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dimlist); + break; +#endif + + case FFESTR_firstTYPE: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V020); + break; + +#if FFESTR_F90 + case FFESTR_firstTYPE: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_type); + break; +#endif + +#if HARD_F90 + case FFESTR_firstTYPE: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_typetype); + break; +#endif + +#if FFESTR_VXT + case FFESTR_firstUNLOCK: + ffestb_args.beru.len = FFESTR_firstlUNLOCK; + ffestb_args.beru.badname = "UNLOCK"; + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_beru); + break; +#endif + +#if FFESTR_VXT + case FFESTR_firstUNION: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V009); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstUSE: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R1107); + break; +#endif + + case FFESTR_firstVIRTUAL: + ffestb_args.R524.len = FFESTR_firstlVIRTUAL; + ffestb_args.R524.badname = "VIRTUAL"; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R524); + break; + + case FFESTR_firstVOLATILE: + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V014); + break; + +#if HARD_F90 + case FFESTR_firstWHERE: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_where); + break; +#endif + + case FFESTR_firstWORD: + ffestb_args.decl.len = FFESTR_firstlWORD; + ffestb_args.decl.type = FFESTP_typeWORD; + ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype); + break; + + case FFESTR_firstWRITE: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R910); + break; + + default: + break; + } + + /* Now check the default cases, which are always "live" (meaning that no + other possibility can override them). These are where the second token + is OPEN_PAREN, PERCENT, EQUALS, POINTS, or COLON. */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + s = ffesymbol_lookup_local (ffesta_token_0_); + if (((s == NULL) || (ffesymbol_dims (s) == NULL)) + && !ffesta_seen_first_exec) + { /* Not known as array; may be stmt function. */ + ffesta_add_possible_unnamed_nonexec_ ((ffelexHandler) ffestb_R1229); + + /* If the symbol is (or will be due to implicit typing) of + CHARACTER type, then the statement might be an assignment + statement. If so, since it can't be a function invocation nor + an array element reference, the open paren following the symbol + name must be followed by an expression and a colon. Without the + colon (which cannot appear in a stmt function definition), the + let stmt rejects. So CHARACTER_NAME(...)=expr, unlike any other + type, is not ambiguous alone. */ + + if (ffeimplic_peek_symbol_type (s, + ffelex_token_text (ffesta_token_0_)) + == FFEINFO_basictypeCHARACTER) + ffesta_add_possible_unnamed_exec_ ((ffelexHandler) ffestb_let); + } + else /* Not statement function if known as an + array. */ + ffesta_add_possible_unnamed_exec_ ((ffelexHandler) ffestb_let); + break; + +#if FFESTR_F90 + case FFELEX_typePERCENT: +#endif + case FFELEX_typeEQUALS: +#if FFESTR_F90 + case FFELEX_typePOINTS: +#endif + ffesta_add_possible_unnamed_exec_ ((ffelexHandler) ffestb_let); + break; + + case FFELEX_typeCOLON: + ffesta_add_possible_exec_ ((ffelexHandler) ffestb_construct); + break; + + default: + ; + } + + /* Now see how many possibilities are on the list. */ + + switch (ffesta_num_possibles_) + { + case 0: /* None, so invalid statement. */ + no_stmts: /* :::::::::::::::::::: */ + ffesta_tokens[0] = ffesta_token_0_; + ffesta_ffebad_2t (FFEBAD_UNREC_STMT, ffesta_token_0_, t); + next = (ffelexHandler) ffelex_swallow_tokens (NULL, + (ffelexHandler) ffesta_zero); + break; + + case 1: /* One, so just do it! */ + ffesta_tokens[0] = ffesta_token_0_; + next = ffesta_possible_execs_.first->handler; + if (next == NULL) + { /* Have a nonexec stmt. */ + next = ffesta_possible_nonexecs_.first->handler; + assert (next != NULL); + } + else if (ffesta_seen_first_exec) + ; /* Have an exec stmt after exec transition. */ + else if (!ffestc_exec_transition ()) + /* 1 exec stmt only, but not valid in context, so pretend as though + statement is unrecognized. */ + goto no_stmts; /* :::::::::::::::::::: */ + break; + + default: /* More than one, so try them in order. */ + ffesta_confirmed_possible_ = NULL; + ffesta_current_possible_ = ffesta_possible_nonexecs_.first; + ffesta_current_handler_ = ffesta_current_possible_->handler; + if (ffesta_current_handler_ == NULL) + { + ffesta_current_possible_ = ffesta_possible_execs_.first; + ffesta_current_handler_ = ffesta_current_possible_->handler; + assert (ffesta_current_handler_ != NULL); + if (!ffesta_seen_first_exec) + { /* Need to do exec transition now. */ + ffesta_tokens[0] = ffesta_token_0_; + if (!ffestc_exec_transition ()) + goto no_stmts; /* :::::::::::::::::::: */ + } + } + ffesta_tokens[0] = ffelex_token_use (ffesta_token_0_); + next = (ffelexHandler) ffesta_save_; + ffebad_set_inhibit (TRUE); + ffesta_is_inhibited_ = TRUE; + break; + } + + ffesta_output_pool + = malloc_pool_new ("Statement Output", ffe_pool_program_unit (), 1024); + ffesta_scratch_pool + = malloc_pool_new ("Statement Scratch", ffe_pool_program_unit (), 1024); + ffesta_outpooldisp_ = FFESTA_pooldispDISCARD; + + if (ffesta_is_inhibited_) + ffesymbol_set_retractable (ffesta_scratch_pool); + + ffelex_set_names (FALSE); /* Most handlers will want this. If not, + they have to set it TRUE again (its value + at the beginning of a statement). */ + + return (ffelexHandler) (*next) (t); +} + +/* ffesta_send_two_ -- Send the two tokens saved by ffesta_two after all + + return ffesta_send_two_; // to lexer. + + Currently, if this function gets called, it means that the two tokens + saved by ffesta_two did not have their handlers derailed by + ffesta_save_, which probably means they weren't sent by ffesta_save_ + but directly by the lexer, which probably means the original statement + (which should be IF (expr) or WHERE (expr)) somehow evaluated to only + one possibility in ffesta_second_ or somebody optimized FFEST to + immediately revert to one possibility upon confirmation but forgot to + change this function (and thus perhaps the entire resubmission + mechanism). */ + +#if !FFESTA_ABORT_ON_CONFIRM_ +static ffelexHandler +ffesta_send_two_ (ffelexToken t) +{ + assert ("what am I doing here?" == NULL); + return NULL; +} + +#endif +/* ffesta_confirmed -- Confirm current possibility as only one + + ffesta_confirmed(); + + Sets the confirmation flag. During debugging for ambiguous constructs, + asserts that the confirmation flag for a previous possibility has not + yet been set. */ + +void +ffesta_confirmed () +{ + if (ffesta_inhibit_confirmation_) + return; + ffesta_confirmed_current_ = TRUE; + assert (!ffesta_confirmed_other_ + || (ffesta_confirmed_possible_ == ffesta_current_possible_)); + ffesta_confirmed_possible_ = ffesta_current_possible_; +} + +/* ffesta_eof -- End of (non-INCLUDEd) source file + + ffesta_eof(); + + Call after piping tokens through ffest_first, where the most recent + token sent through must be EOS. + + 20-Feb-91 JCB 1.1 + Put new EOF token in ffesta_tokens[0], not NULL, because too much + code expects something there for error reporting and the like. Also, + do basically the same things ffest_second and ffesta_zero do for + processing a statement (make and destroy pools, et cetera). */ + +void +ffesta_eof () +{ + ffesta_tokens[0] = ffelex_token_new_eof (); + + ffesta_output_pool + = malloc_pool_new ("Statement Output", ffe_pool_program_unit (), 1024); + ffesta_scratch_pool + = malloc_pool_new ("Statement Scratch", ffe_pool_program_unit (), 1024); + ffesta_outpooldisp_ = FFESTA_pooldispDISCARD; + + ffestc_eof (); + + if (ffesta_tokens[0] != NULL) + ffelex_token_kill (ffesta_tokens[0]); + + if (ffesta_output_pool != NULL) + { + if (ffesta_outpooldisp_ == FFESTA_pooldispDISCARD) + malloc_pool_kill (ffesta_output_pool); + ffesta_output_pool = NULL; + } + + if (ffesta_scratch_pool != NULL) + { + malloc_pool_kill (ffesta_scratch_pool); + ffesta_scratch_pool = NULL; + } + + if (ffesta_label_token != NULL) + { + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; + } + + if (ffe_is_ffedebug ()) + { + ffestorag_report (); + ffesymbol_report_all (); + } +} + +/* ffesta_ffebad_here_current_stmt -- ffebad_here with ptr to current stmt + + ffesta_ffebad_here_current_stmt(0); + + Outsiders can call this fn if they have no more convenient place to + point to (via a token or pair of ffewhere objects) and they know a + current, useful statement is being evaluted by ffest (i.e. they are + being called from ffestb, ffestc, ffestd, ... functions). */ + +void +ffesta_ffebad_here_current_stmt (ffebadIndex i) +{ + assert (ffesta_tokens[0] != NULL); + ffebad_here (i, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); +} + +/* ffesta_ffebad_start -- Start a possibly inhibited error report + + if (ffesta_ffebad_start(FFEBAD_SOME_ERROR)) + { + ffebad_here, ffebad_string ...; + ffebad_finish(); + } + + Call if the error might indicate that ffest is evaluating the wrong + statement form, instead of calling ffebad_start directly. If ffest + is choosing between forms, it will return FALSE, send an EOS/SEMICOLON + token through as the next token (if the current one isn't already one + of those), and try another possible form. Otherwise, ffebad_start is + called with the argument and TRUE returned. */ + +bool +ffesta_ffebad_start (ffebad errnum) +{ + if (!ffesta_is_inhibited_) + { + ffebad_start (errnum); + return TRUE; + } + + if (!ffesta_confirmed_current_) + ffesta_current_shutdown_ = TRUE; + + return FALSE; +} + +/* ffesta_first -- Parse the first token in a statement + + return ffesta_first; // to lexer. */ + +ffelexHandler +ffesta_first (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeSEMICOLON: + case FFELEX_typeEOS: + ffesta_tokens[0] = ffelex_token_use (t); + if (ffesta_label_token != NULL) + { + ffebad_start (FFEBAD_LABEL_WITHOUT_STMT); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_string (ffelex_token_text (ffesta_label_token)); + ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeNAME: + case FFELEX_typeNAMES: + ffesta_token_0_ = ffelex_token_use (t); + ffesta_first_kw = ffestr_first (t); + return (ffelexHandler) ffesta_second_; + + case FFELEX_typeNUMBER: + if (ffesta_line_has_semicolons + && !ffe_is_free_form () + && ffe_is_pedantic ()) + { + ffebad_start (FFEBAD_LABEL_WRONG_PLACE); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_string (ffelex_token_text (t)); + ffebad_finish (); + } + if (ffesta_label_token == NULL) + { + ffesta_label_token = ffelex_token_use (t); + return (ffelexHandler) ffesta_first; + } + else + { + ffebad_start (FFEBAD_EXTRA_LABEL_DEF); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_string (ffelex_token_text (t)); + ffebad_here (1, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_string (ffelex_token_text (ffesta_label_token)); + ffebad_finish (); + + return (ffelexHandler) ffesta_first; + } + + default: /* Invalid first token. */ + ffesta_tokens[0] = ffelex_token_use (t); + ffebad_start (FFEBAD_STMT_BEGINS_BAD); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + } +} + +/* ffesta_init_0 -- Initialize for entire image invocation + + ffesta_init_0(); + + Call just once per invocation of the compiler (not once per invocation + of the front end). + + Gets memory for the list of possibles once and for all, since this + list never gets larger than a certain size (FFESTA_maxPOSSIBLES_) + and is not particularly large. Initializes the array of pointers to + this list. Initializes the executable and nonexecutable lists. */ + +void +ffesta_init_0 () +{ + ffestaPossible_ ptr; + int i; + + ptr = (ffestaPossible_) malloc_new_kp (malloc_pool_image (), + "FFEST possibles", + FFESTA_maxPOSSIBLES_ + * sizeof (*ptr)); + + for (i = 0; i < FFESTA_maxPOSSIBLES_; ++i) + ffesta_possibles_[i] = ptr++; + + ffesta_possible_execs_.first = ffesta_possible_execs_.last + = (ffestaPossible_) &ffesta_possible_execs_.first; + ffesta_possible_nonexecs_.first = ffesta_possible_nonexecs_.last + = (ffestaPossible_) &ffesta_possible_nonexecs_.first; + ffesta_possible_execs_.nil = ffesta_possible_nonexecs_.nil = NULL; +} + +/* ffesta_init_3 -- Initialize for any program unit + + ffesta_init_3(); */ + +void +ffesta_init_3 () +{ + ffesta_output_pool = NULL; /* May be doing this just before reaching */ + ffesta_scratch_pool = NULL; /* ffesta_zero or ffesta_two. */ + /* NOTE: we let the ffe_terminate_2 action of killing the program_unit pool + handle the killing of the output and scratch pools for us, which is why + we don't have a terminate_3 action to do so. */ + ffesta_construct_name = NULL; + ffesta_label_token = NULL; + ffesta_seen_first_exec = FALSE; +} + +/* ffesta_is_inhibited -- Test whether the current possibility is inhibited + + if (!ffesta_is_inhibited()) + // implement the statement. + + Just make sure the current possibility has been confirmed. If anyone + really needs to test whether the current possibility is inhibited prior + to confirming it, that indicates a need to begin statement processing + before it is certain that the given possibility is indeed the statement + to be processed. As of this writing, there does not appear to be such + a need. If there is, then when confirming a statement would normally + immediately disable the inhibition (whereas currently we leave the + confirmed statement disabled until we've tried the other possibilities, + to check for ambiguities), we must check to see if the possibility has + already tested for inhibition prior to confirmation and, if so, maintain + inhibition until the end of the statement (which may be forced right + away) and then rerun the entire statement from the beginning. Otherwise, + initial calls to ffestb functions won't have been made, but subsequent + calls (after confirmation) will, which is wrong. Of course, this all + applies only to those statements implemented via multiple calls to + ffestb, although if a statement requiring only a single ffestb call + tested for inhibition prior to confirmation, it would likely mean that + the ffestb call would be completely dropped without this mechanism. */ + +bool +ffesta_is_inhibited () +{ + assert (ffesta_confirmed_current_ || ffesta_inhibit_confirmation_); + return ffesta_is_inhibited_; +} + +/* ffesta_ffebad_1p -- Issue diagnostic with one source character + + ffelexToken names_token; + ffeTokenLength index; + ffelexToken next_token; + ffesta_ffebad_1p(FFEBAD_SOME_ERROR,names_token,index,next_token); + + Equivalent to "if (ffest_ffebad_start(FFEBAD_SOME_ERROR))" followed by + sending one argument, the location of index with names_token, if TRUE is + returned. If index is equal to the length of names_token, meaning it + points to the end of the token, then uses the location in next_token + (which should be the token sent by the lexer after it sent names_token) + instead. */ + +void +ffesta_ffebad_1p (ffebad errnum, ffelexToken names_token, ffeTokenLength index, + ffelexToken next_token) +{ + ffewhereLine line; + ffewhereColumn col; + + assert (index <= ffelex_token_length (names_token)); + + if (ffesta_ffebad_start (errnum)) + { + if (index == ffelex_token_length (names_token)) + { + assert (next_token != NULL); + line = ffelex_token_where_line (next_token); + col = ffelex_token_where_column (next_token); + ffebad_here (0, line, col); + } + else + { + ffewhere_set_from_track (&line, &col, + ffelex_token_where_line (names_token), + ffelex_token_where_column (names_token), + ffelex_token_wheretrack (names_token), + index); + ffebad_here (0, line, col); + ffewhere_line_kill (line); + ffewhere_column_kill (col); + } + ffebad_finish (); + } +} + +void +ffesta_ffebad_1sp (ffebad errnum, char *s, ffelexToken names_token, + ffeTokenLength index, ffelexToken next_token) +{ + ffewhereLine line; + ffewhereColumn col; + + assert (index <= ffelex_token_length (names_token)); + + if (ffesta_ffebad_start (errnum)) + { + ffebad_string (s); + if (index == ffelex_token_length (names_token)) + { + assert (next_token != NULL); + line = ffelex_token_where_line (next_token); + col = ffelex_token_where_column (next_token); + ffebad_here (0, line, col); + } + else + { + ffewhere_set_from_track (&line, &col, + ffelex_token_where_line (names_token), + ffelex_token_where_column (names_token), + ffelex_token_wheretrack (names_token), + index); + ffebad_here (0, line, col); + ffewhere_line_kill (line); + ffewhere_column_kill (col); + } + ffebad_finish (); + } +} + +void +ffesta_ffebad_1st (ffebad errnum, char *s, ffelexToken t) +{ + if (ffesta_ffebad_start (errnum)) + { + ffebad_string (s); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } +} + +/* ffesta_ffebad_1t -- Issue diagnostic with one source token + + ffelexToken t; + ffesta_ffebad_1t(FFEBAD_SOME_ERROR,t); + + Equivalent to "if (ffesta_ffebad_start(FFEBAD_SOME_ERROR))" followed by + sending one argument, the location of the token t, if TRUE is returned. */ + +void +ffesta_ffebad_1t (ffebad errnum, ffelexToken t) +{ + if (ffesta_ffebad_start (errnum)) + { + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } +} + +void +ffesta_ffebad_2st (ffebad errnum, char *s, ffelexToken t1, ffelexToken t2) +{ + if (ffesta_ffebad_start (errnum)) + { + ffebad_string (s); + ffebad_here (0, ffelex_token_where_line (t1), ffelex_token_where_column (t1)); + ffebad_here (1, ffelex_token_where_line (t2), ffelex_token_where_column (t2)); + ffebad_finish (); + } +} + +/* ffesta_ffebad_2t -- Issue diagnostic with two source tokens + + ffelexToken t1, t2; + ffesta_ffebad_2t(FFEBAD_SOME_ERROR,t1,t2); + + Equivalent to "if (ffesta_ffebad_start(FFEBAD_SOME_ERROR))" followed by + sending two argument, the locations of the tokens t1 and t2, if TRUE is + returned. */ + +void +ffesta_ffebad_2t (ffebad errnum, ffelexToken t1, ffelexToken t2) +{ + if (ffesta_ffebad_start (errnum)) + { + ffebad_here (0, ffelex_token_where_line (t1), ffelex_token_where_column (t1)); + ffebad_here (1, ffelex_token_where_line (t2), ffelex_token_where_column (t2)); + ffebad_finish (); + } +} + +/* ffesta_set_outpooldisp -- Set disposition of statement output pool + + ffesta_set_outpooldisp(FFESTA_pooldispPRESERVE); */ + +void +ffesta_set_outpooldisp (ffestaPooldisp d) +{ + ffesta_outpooldisp_ = d; +} + +/* Shut down current parsing possibility, but without bothering the + user with a diagnostic if we're not inhibited. */ + +void +ffesta_shutdown () +{ + if (ffesta_is_inhibited_) + ffesta_current_shutdown_ = TRUE; +} + +/* ffesta_two -- Deal with the first two tokens after a swallowed statement + + return ffesta_two(first_token,second_token); // to lexer. + + Like ffesta_zero, except instead of expecting an EOS or SEMICOLON, it + expects the first two tokens of a statement that is part of another + statement: the first two tokens of statement in "IF (expr) statement" or + "WHERE (expr) statement", in particular. The first token must be a NAME + or NAMES, the second can be basically anything. The statement type MUST + be confirmed by now. + + If we're not inhibited, just handle things as if we were ffesta_zero + and saw an EOS just before the two tokens. + + If we're inhibited, set ffesta_current_shutdown_ to shut down the current + statement and continue with other possibilities, then (presumably) come + back to this one for real when not inhibited. */ + +ffelexHandler +ffesta_two (ffelexToken first, ffelexToken second) +{ +#if FFESTA_ABORT_ON_CONFIRM_ + ffelexHandler next; +#endif + + assert ((ffelex_token_type (first) == FFELEX_typeNAME) + || (ffelex_token_type (first) == FFELEX_typeNAMES)); + assert (ffesta_tokens[0] != NULL); + + if (ffesta_is_inhibited_) /* Oh, not really done with statement. */ + { + ffesta_current_shutdown_ = TRUE; + /* To catch the EOS on shutdown. */ + return (ffelexHandler) ffelex_swallow_tokens (second, + (ffelexHandler) ffesta_zero); + } + + ffestw_display_state (); + + ffelex_token_kill (ffesta_tokens[0]); + + if (ffesta_output_pool != NULL) + { + if (ffesta_outpooldisp_ == FFESTA_pooldispDISCARD) + malloc_pool_kill (ffesta_output_pool); + ffesta_output_pool = NULL; + } + + if (ffesta_scratch_pool != NULL) + { + malloc_pool_kill (ffesta_scratch_pool); + ffesta_scratch_pool = NULL; + } + + ffesta_reset_possibles_ (); + ffesta_confirmed_current_ = FALSE; + + /* What happens here is somewhat interesting. We effectively derail the + line of handlers for these two tokens, the first two in a statement, by + setting a flag to TRUE. This flag tells ffesta_save_ (or, conceivably, + the lexer via ffesta_second_'s case 1:, where it has only one possible + kind of statement -- someday this will be more likely, i.e. after + confirmation causes an immediate switch to only the one context rather + than just setting a flag and running through the remaining possibles to + look for ambiguities) that the last two tokens it sent did not reach the + truly desired targets (ffest_first and ffesta_second_) since that would + otherwise attempt to recursively invoke ffesta_save_ in most cases, + while the existing ffesta_save_ was still alive and making use of static + (nonrecursive) variables. Instead, ffesta_save_, upon seeing this flag + set TRUE, sets it to FALSE and resubmits the two tokens copied here to + ffest_first and, presumably, ffesta_second_, kills them, and returns the + handler returned by the handler for the second token. Thus, even though + ffesta_save_ is still (likely to be) recursively invoked, the former + invocation is past the use of any static variables possibly changed + during the first-two-token invocation of the latter invocation. */ + +#if FFESTA_ABORT_ON_CONFIRM_ + /* Shouldn't be in ffesta_save_ at all here. */ + + next = (ffelexHandler) ffesta_first (first); + return (ffelexHandler) (*next) (second); +#else + ffesta_twotokens_1_ = ffelex_token_use (first); + ffesta_twotokens_2_ = ffelex_token_use (second); + + ffesta_is_two_into_statement_ = TRUE; + return (ffelexHandler) ffesta_send_two_; /* Shouldn't get called. */ +#endif +} + +/* ffesta_zero -- Deal with the end of a swallowed statement + + return ffesta_zero; // to lexer. + + NOTICE that this code is COPIED, largely, into a + similar function named ffesta_two that gets invoked in place of + _zero_ when the end of the statement happens before EOS or SEMICOLON and + to tokens into the next statement have been read (as is the case with the + logical-IF and WHERE-stmt statements). So any changes made here should + probably be made in _two_ at the same time. */ + +ffelexHandler +ffesta_zero (ffelexToken t) +{ + assert ((ffelex_token_type (t) == FFELEX_typeEOS) + || (ffelex_token_type (t) == FFELEX_typeSEMICOLON)); + assert (ffesta_tokens[0] != NULL); + + if (ffesta_is_inhibited_) + ffesymbol_retract (TRUE); + else + ffestw_display_state (); + + /* Do CONTINUE if nothing else. This is done specifically so that "IF + (...) BLAH" causes the same things to happen as if "IF (...) CONTINUE" + was done, so that tracking of labels and such works. (Try a small + program like "DO 10 ...", "IF (...) BLAH", "10 CONTINUE", "END".) + + But it turns out that just testing "!ffesta_confirmed_current_" + isn't enough, because then typing "GOTO" instead of "BLAH" above + doesn't work -- the statement is confirmed (we know the user + attempted a GOTO) but ffestc hasn't seen it. So, instead, just + always tell ffestc to do "any" statement it needs to to reset. */ + + if (!ffesta_is_inhibited_ + && ffesta_seen_first_exec) + { + ffestc_any (); + } + + ffelex_token_kill (ffesta_tokens[0]); + + if (ffesta_is_inhibited_) /* Oh, not really done with statement. */ + return (ffelexHandler) ffesta_zero; /* Call me again when done! */ + + if (ffesta_output_pool != NULL) + { + if (ffesta_outpooldisp_ == FFESTA_pooldispDISCARD) + malloc_pool_kill (ffesta_output_pool); + ffesta_output_pool = NULL; + } + + if (ffesta_scratch_pool != NULL) + { + malloc_pool_kill (ffesta_scratch_pool); + ffesta_scratch_pool = NULL; + } + + ffesta_reset_possibles_ (); + ffesta_confirmed_current_ = FALSE; + + if (ffelex_token_type (t) == FFELEX_typeSEMICOLON) + { + ffesta_line_has_semicolons = TRUE; + if (ffe_is_pedantic_not_90 ()) + { + ffebad_start (FFEBAD_SEMICOLON); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + } + else + ffesta_line_has_semicolons = FALSE; + + if (ffesta_label_token != NULL) + { + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; + } + + if (ffe_is_ffedebug ()) + { + ffestorag_report (); + ffesymbol_report_all (); + } + + ffelex_set_names (TRUE); + return (ffelexHandler) ffesta_first; +} diff --git a/gcc/f/sta.h b/gcc/f/sta.h new file mode 100644 index 000000000000..132d0e84d4bc --- /dev/null +++ b/gcc/f/sta.h @@ -0,0 +1,116 @@ +/* sta.h -- Private #include File (module.h template V1.0) + Copyright (C) 1995 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + sta.c + + Modifications: +*/ + +/* Allow multiple inclusion to work. */ + +#ifndef _H_f_sta +#define _H_f_sta + +/* Simple definitions and enumerations. */ + +typedef enum + { + FFESTA_pooldispDISCARD, /* Default state. */ + FFESTA_pooldispPRESERVE, /* Preserve through end of program unit. */ + FFESTA_pooldisp + } ffestaPooldisp; + +#define FFESTA_tokensMAX 10 /* Max # tokens in fixed positions. */ + +/* Typedefs. */ + +/* Include files needed by this one. */ + +#include "bad.h" +#include "lex.h" +#include "malloc.h" +#include "str.h" +#include "symbol.h" + +typedef mallocPool ffestaPool; /* No need for use count yet. */ + +/* Structure definitions. */ + + +/* Global objects accessed by users of this module. */ + +extern ffelexToken ffesta_tokens[FFESTA_tokensMAX]; +extern ffestrFirst ffesta_first_kw; +extern ffestrSecond ffesta_second_kw; +extern mallocPool ffesta_output_pool; +extern mallocPool ffesta_scratch_pool; +extern ffelexToken ffesta_construct_name; +extern ffelexToken ffesta_label_token; +extern bool ffesta_seen_first_exec; +extern bool ffesta_is_entry_valid; +extern bool ffesta_line_has_semicolons; + +/* Declare functions with prototypes. */ + +void ffesta_confirmed (void); +void ffesta_eof (void); +bool ffesta_ffebad_start (ffebad errnum); +void ffesta_ffebad_here_current_stmt (ffebadIndex i); +ffelexHandler ffesta_first (ffelexToken t); +void ffesta_init_0 (void); +void ffesta_init_3 (void); +bool ffesta_is_inhibited (void); +void ffesta_terminate_0 (void); +void ffesta_terminate_1 (void); +void ffesta_terminate_2 (void); +void ffesta_terminate_3 (void); +void ffesta_terminate_4 (void); +void ffesta_ffebad_here_doiter (ffebadIndex i, ffesymbol s); +void ffesta_shutdown (void); +ffesymbol ffesta_sym_end_transition (ffesymbol s); +ffesymbol ffesta_sym_exec_transition (ffesymbol s); +void ffesta_ffebad_1p (ffebad msg, ffelexToken names_token, + ffeTokenLength index, ffelexToken next_token); +void ffesta_ffebad_1sp (ffebad msg, char *s, ffelexToken names_token, + ffeTokenLength index, ffelexToken next_token); +void ffesta_ffebad_1st (ffebad msg, char *s, ffelexToken t); +void ffesta_ffebad_1t (ffebad msg, ffelexToken t); +void ffesta_ffebad_2st (ffebad msg, char *s, ffelexToken t1, ffelexToken t2); +void ffesta_ffebad_2t (ffebad msg, ffelexToken t1, ffelexToken t2); +ffelexHandler ffesta_zero (ffelexToken t); +ffelexHandler ffesta_two (ffelexToken first, ffelexToken second); +void ffesta_set_outpooldisp (ffestaPooldisp d); + +/* Define macros. */ + +#define ffesta_init_1() +#define ffesta_init_2() +#define ffesta_init_4() +#define ffesta_terminate_0() +#define ffesta_terminate_1() +#define ffesta_terminate_2() +#define ffesta_terminate_3() +#define ffesta_terminate_4() + +/* End of #include file. */ + +#endif diff --git a/gcc/f/stb.c b/gcc/f/stb.c new file mode 100644 index 000000000000..90ecc5f8f475 --- /dev/null +++ b/gcc/f/stb.c @@ -0,0 +1,25192 @@ +/* stb.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995, 1996 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + st.c + + Description: + Parses the proper form for statements, builds up expression trees for + them, but does not actually implement them. Uses ffebad (primarily via + ffesta_ffebad_start) to indicate errors in form. In many cases, an invalid + statement form indicates another possible statement needs to be looked at + by ffest. In a few cases, a valid statement form might not completely + determine the nature of the statement, as in REALFUNCTIONA(B), which is + a valid form for either the first statement of a function named A taking + an argument named B or for the declaration of a real array named FUNCTIONA + with an adjustable size of B. A similar (though somewhat easier) choice + must be made for the statement-function-def vs. assignment forms, as in + the case of FOO(A) = A+2.0. + + A given parser consists of one or more state handlers, the first of which + is the initial state, and the last of which (for any given input) returns + control to a final state handler (ffesta_zero or ffesta_two, explained + below). The functions handling the states for a given parser usually have + the same names, differing only in the final number, as in ffestb_foo_ + (handles the initial state), ffestb_foo_1_, ffestb_foo_2_ (handle + subsequent states), although liberties sometimes are taken with the "foo" + part either when keywords are clarified into given statements or are + transferred into other possible areas. (For example, the type-name + states can hop over to _dummy_ functions when the FUNCTION or RECURSIVE + keywords are seen, though this kind of thing is kept to a minimum.) Only + the names without numbers are exported to the rest of ffest; the others + are local (static). + + Each initial state is provided with the first token in ffesta_tokens[0], + which will be killed upon return to the final state (ffesta_zero or + ffelex_swallow_tokens passed through to ffesta_zero), so while it may + be changed to another token, a valid token must be left there to be + killed. Also, a "convenient" array of tokens are left in + ffesta_tokens[1..FFESTA_tokensMAX]. The initial state of this set of + elements is undefined, thus, if tokens are stored here, they must be + killed before returning to the final state. Any parser may also use + cross-state local variables by sticking a structure containing storage + for those variables in the local union ffestb_local_ (unless the union + goes on strike). Furthermore, parsers that handle more than one first or + second tokens (like _varlist_, which handles EXTERNAL, INTENT, INTRINSIC, + OPTIONAL, + PUBLIC, or PRIVATE, and _endxyz_, which handles ENDBLOCK, ENDBLOCKDATA, + ENDDO, ENDIF, and so on) may expect arguments from ffest in the + ffest-wide union ffest_args_, the substructure specific to the parser. + + A parser's responsibility is: to call either ffesta_confirmed or + ffest_ffebad_start before returning to the final state; to be the only + parser that can possibly call ffesta_confirmed for a given statement; + to call ffest_ffebad_start immediately upon recognizing a bad token + (specifically one that another statement parser might confirm upon); + to call ffestc functions only after calling ffesta_confirmed and only + when ffesta_is_inhibited returns FALSE; and to call ffesta_is_inhibited + only after calling ffesta_confirmed. Confirm as early as reasonably + possible, even when only one ffestc function is called for the statement + later on, because early confirmation can enhance the error-reporting + capabilities if a subsequent error is detected and this parser isn't + the first possibility for the statement. + + To assist the parser, functions like ffesta_ffebad_1t and _1p_ have + been provided to make use of ffest_ffebad_start fairly easy. + + Modifications: +*/ + +/* Include files. */ + +#include "proj.h" +#include +#include "stb.h" +#include "bad.h" +#include "expr.h" +#include "lex.h" +#include "malloc.h" +#include "src.h" +#include "sta.h" +#include "stc.h" +#include "stp.h" +#include "str.h" + +/* Externals defined here. */ + +struct _ffestb_args_ ffestb_args; + +/* Simple definitions and enumerations. */ + +#define FFESTB_KILL_EASY_ 1 /* 1 for only one _subr_kill_xyz_ fn. */ + +/* Internal typedefs. */ + +union ffestb_subrargs_u_ + { + struct + { + ffesttTokenList labels; /* Input arg, must not be NULL. */ + ffelexHandler handler; /* Input arg, call me when done. */ + bool ok; /* Output arg, TRUE if list ended in + CLOSE_PAREN. */ + } + label_list; + struct + { + ffesttDimList dims; /* Input arg, must not be NULL. */ + ffelexHandler handler; /* Input arg, call me when done. */ + mallocPool pool; /* Pool to allocate into. */ + bool ok; /* Output arg, TRUE if list ended in + CLOSE_PAREN. */ + ffeexprContext ctx; /* DIMLIST or DIMLISTCOMMON. */ +#ifdef FFECOM_dimensionsMAX + int ndims; /* For backends that really can't have + infinite dims. */ +#endif + } + dim_list; + struct + { + ffesttTokenList args; /* Input arg, must not be NULL. */ + ffelexHandler handler; /* Input arg, call me when done. */ + ffelexToken close_paren;/* Output arg if ok, CLOSE_PAREN token. */ + bool is_subr; /* Input arg, TRUE if list in subr-def + context. */ + bool ok; /* Output arg, TRUE if list ended in + CLOSE_PAREN. */ + bool names; /* Do ffelex_set_names(TRUE) before return. */ + } + name_list; + }; + +union ffestb_local_u_ + { + struct + { + ffebld expr; + } + call_stmt; + struct + { + ffebld expr; + } + go_to; + struct + { + ffebld dest; + bool vxtparam; /* If assignment might really be VXT + PARAMETER stmt. */ + } + let; + struct + { + ffebld expr; + } + if_stmt; + struct + { + ffebld expr; + } + else_stmt; + struct + { + ffebld expr; + } + dowhile; + struct + { + ffebld var; + ffebld start; + ffebld end; + } + do_stmt; + struct + { + bool is_cblock; + } + R522; + struct + { + ffebld expr; + bool started; + } + parameter; + struct + { + ffesttExprList exprs; + bool started; + } + equivalence; + struct + { + ffebld expr; + bool started; + } + data; + struct + { + ffestrOther kw; + } + varlist; +#if FFESTR_F90 + struct + { + ffestrOther kw; + } + type; +#endif + struct + { + ffelexHandler next; + } + construct; + struct + { + ffesttFormatList f; + ffestpFormatType current; /* What we're currently working on. */ + ffelexToken t; /* Token of what we're currently working on. */ + ffesttFormatValue pre; + ffesttFormatValue post; + ffesttFormatValue dot; + ffesttFormatValue exp; + bool sign; /* _3_, pos/neg; elsewhere, signed/unsigned. */ + bool complained; /* If run-time expr seen in nonexec context. */ + } + format; +#if FFESTR_F90 + struct + { + bool started; + } + moduleprocedure; +#endif + struct + { + ffebld expr; + } + selectcase; + struct + { + ffesttCaseList cases; + } + case_stmt; +#if FFESTR_F90 + struct + { + ffesttExprList exprs; + ffebld expr; + } + heap; +#endif +#if FFESTR_F90 + struct + { + ffesttExprList exprs; + } + R624; +#endif +#if FFESTR_F90 + struct + { + ffestpDefinedOperator operator; + bool assignment; /* TRUE for INTERFACE ASSIGNMENT, FALSE for + ...OPERATOR. */ + bool slash; /* TRUE if OPEN_ARRAY, FALSE if OPEN_PAREN. */ + } + interface; +#endif + struct + { + bool is_cblock; + } + V014; +#if FFESTR_VXT + struct + { + bool started; + ffebld u; + ffebld m; + ffebld n; + ffebld asv; + } + V025; +#endif + struct + { + ffestpBeruIx ix; + bool label; + bool left; + ffeexprContext context; + } + beru; + struct + { + ffestpCloseIx ix; + bool label; + bool left; + ffeexprContext context; + } + close; + struct + { + ffestpDeleteIx ix; + bool label; + bool left; + ffeexprContext context; + } + delete; + struct + { + ffestpDeleteIx ix; + bool label; + bool left; + ffeexprContext context; + } + find; + struct + { + ffestpInquireIx ix; + bool label; + bool left; + ffeexprContext context; + bool may_be_iolength; + } + inquire; + struct + { + ffestpOpenIx ix; + bool label; + bool left; + ffeexprContext context; + } + open; + struct + { + ffestpReadIx ix; + bool label; + bool left; + ffeexprContext context; + } + read; + struct + { + ffestpRewriteIx ix; + bool label; + bool left; + ffeexprContext context; + } + rewrite; + struct + { + ffestpWriteIx ix; + bool label; + bool left; + ffeexprContext context; + } + vxtcode; + struct + { + ffestpWriteIx ix; + bool label; + bool left; + ffeexprContext context; + } + write; +#if FFESTR_F90 + struct + { + bool started; + } + structure; +#endif + struct + { + bool started; + } + common; + struct + { + bool started; + } + dimension; + struct + { + bool started; + } + dimlist; + struct + { + char *badname; + ffestrFirst first_kw; + bool is_subr; + } + dummy; + struct + { + ffebld kind; /* Kind type parameter, if any. */ + ffelexToken kindt; /* Kind type first token, if any. */ + ffebld len; /* Length type parameter, if any. */ + ffelexToken lent; /* Length type parameter, if any. */ + ffelexHandler handler; + ffelexToken recursive; + ffebld expr; + ffesttTokenList toklist;/* For ambiguity resolution. */ + ffesttImpList imps; /* List of IMPLICIT letters. */ + ffelexHandler imp_handler; /* Call if paren list wasn't letters. */ + char *badname; + ffestrOther kw; /* INTENT(IN/OUT/INOUT). */ + ffestpType type; + bool parameter; /* If PARAMETER attribute seen (governs =expr + context). */ + bool coloncolon; /* If COLONCOLON seen (allows =expr). */ + bool aster_after; /* "*" seen after, not before, + [RECURSIVE]FUNCTIONxyz. */ + bool empty; /* Ambig function dummy arg list empty so + far? */ + bool imp_started; /* Started IMPLICIT statement already. */ + bool imp_seen_comma; /* TRUE if next COMMA within parens means not + R541. */ + } + decl; + struct + { + bool started; + } + vxtparam; + }; /* Merge with the one in ffestb later. */ + +/* Private include files. */ + + +/* Internal structure definitions. */ + + +/* Static objects accessed by functions in this module. */ + +static union ffestb_subrargs_u_ ffestb_subrargs_; +static union ffestb_local_u_ ffestb_local_; + +/* Static functions (internal). */ + +static void ffestb_subr_ambig_to_ents_ (void); +static ffelexHandler ffestb_subr_ambig_nope_ (ffelexToken t); +static ffelexHandler ffestb_subr_dimlist_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_subr_dimlist_1_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_subr_dimlist_2_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_subr_name_list_ (ffelexToken t); +static ffelexHandler ffestb_subr_name_list_1_ (ffelexToken t); +static void ffestb_subr_R1001_append_p_ (void); +static ffelexHandler ffestb_decl_kindparam_ (ffelexToken t); +static ffelexHandler ffestb_decl_kindparam_1_ (ffelexToken t); +static ffelexHandler ffestb_decl_kindparam_2_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_decl_starkind_ (ffelexToken t); +static ffelexHandler ffestb_decl_starlen_ (ffelexToken t); +static ffelexHandler ffestb_decl_starlen_1_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_decl_typeparams_ (ffelexToken t); +static ffelexHandler ffestb_decl_typeparams_1_ (ffelexToken t); +static ffelexHandler ffestb_decl_typeparams_2_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_decl_typeparams_3_ (ffelexToken ft, ffebld expr, + ffelexToken t); +#if FFESTR_F90 +static ffelexHandler ffestb_decl_typetype1_ (ffelexToken t); +static ffelexHandler ffestb_decl_typetype2_ (ffelexToken t); +#endif +static ffelexHandler ffestb_subr_label_list_ (ffelexToken t); +static ffelexHandler ffestb_subr_label_list_1_ (ffelexToken t); +static ffelexHandler ffestb_do1_ (ffelexToken t); +static ffelexHandler ffestb_do2_ (ffelexToken t); +static ffelexHandler ffestb_do3_ (ffelexToken t); +static ffelexHandler ffestb_do4_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_do5_ (ffelexToken t); +static ffelexHandler ffestb_do6_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_do7_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_do8_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_do9_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_else1_ (ffelexToken t); +static ffelexHandler ffestb_else2_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_else3_ (ffelexToken t); +static ffelexHandler ffestb_else4_ (ffelexToken t); +static ffelexHandler ffestb_else5_ (ffelexToken t); +static ffelexHandler ffestb_end1_ (ffelexToken t); +static ffelexHandler ffestb_end2_ (ffelexToken t); +static ffelexHandler ffestb_end3_ (ffelexToken t); +static ffelexHandler ffestb_goto1_ (ffelexToken t); +static ffelexHandler ffestb_goto2_ (ffelexToken t); +static ffelexHandler ffestb_goto3_ (ffelexToken t); +static ffelexHandler ffestb_goto4_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_goto5_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_goto6_ (ffelexToken t); +static ffelexHandler ffestb_goto7_ (ffelexToken t); +static ffelexHandler ffestb_halt1_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_if1_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_if2_ (ffelexToken t); +static ffelexHandler ffestb_if3_ (ffelexToken t); +static ffelexHandler ffestb_let1_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_let2_ (ffelexToken ft, ffebld expr, + ffelexToken t); +#if FFESTR_F90 +static ffelexHandler ffestb_type1_ (ffelexToken t); +static ffelexHandler ffestb_type2_ (ffelexToken t); +static ffelexHandler ffestb_type3_ (ffelexToken t); +static ffelexHandler ffestb_type4_ (ffelexToken t); +#endif +#if FFESTR_F90 +static ffelexHandler ffestb_varlist1_ (ffelexToken t); +static ffelexHandler ffestb_varlist2_ (ffelexToken t); +static ffelexHandler ffestb_varlist3_ (ffelexToken t); +static ffelexHandler ffestb_varlist4_ (ffelexToken t); +#endif +static ffelexHandler ffestb_varlist5_ (ffelexToken t); +static ffelexHandler ffestb_varlist6_ (ffelexToken t); +#if FFESTR_F90 +static ffelexHandler ffestb_where1_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_where2_ (ffelexToken t); +static ffelexHandler ffestb_where3_ (ffelexToken t); +#endif +static ffelexHandler ffestb_R5221_ (ffelexToken t); +static ffelexHandler ffestb_R5222_ (ffelexToken t); +static ffelexHandler ffestb_R5223_ (ffelexToken t); +static ffelexHandler ffestb_R5224_ (ffelexToken t); +static ffelexHandler ffestb_R5281_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R5282_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R5283_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R5284_ (ffelexToken t); +static ffelexHandler ffestb_R5371_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R5372_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R5373_ (ffelexToken t); +static ffelexHandler ffestb_R5421_ (ffelexToken t); +static ffelexHandler ffestb_R5422_ (ffelexToken t); +static ffelexHandler ffestb_R5423_ (ffelexToken t); +static ffelexHandler ffestb_R5424_ (ffelexToken t); +static ffelexHandler ffestb_R5425_ (ffelexToken t); +static ffelexHandler ffestb_R5441_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R5442_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R5443_ (ffelexToken t); +static ffelexHandler ffestb_R5444_ (ffelexToken t); +static ffelexHandler ffestb_R8341_ (ffelexToken t); +static ffelexHandler ffestb_R8351_ (ffelexToken t); +static ffelexHandler ffestb_R8381_ (ffelexToken t); +static ffelexHandler ffestb_R8382_ (ffelexToken t); +static ffelexHandler ffestb_R8383_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R8401_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R8402_ (ffelexToken t); +static ffelexHandler ffestb_R8403_ (ffelexToken t); +static ffelexHandler ffestb_R8404_ (ffelexToken t); +static ffelexHandler ffestb_R8405_ (ffelexToken t); +static ffelexHandler ffestb_R8406_ (ffelexToken t); +static ffelexHandler ffestb_R8407_ (ffelexToken t); +static ffelexHandler ffestb_R11021_ (ffelexToken t); +static ffelexHandler ffestb_R1111_1_ (ffelexToken t); +static ffelexHandler ffestb_R1111_2_ (ffelexToken t); +static ffelexHandler ffestb_R12121_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R12271_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_construct1_ (ffelexToken t); +static ffelexHandler ffestb_construct2_ (ffelexToken t); +#if FFESTR_F90 +static ffelexHandler ffestb_heap1_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_heap2_ (ffelexToken t); +static ffelexHandler ffestb_heap3_ (ffelexToken t); +static ffelexHandler ffestb_heap4_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_heap5_ (ffelexToken t); +#endif +#if FFESTR_F90 +static ffelexHandler ffestb_module1_ (ffelexToken t); +static ffelexHandler ffestb_module2_ (ffelexToken t); +static ffelexHandler ffestb_module3_ (ffelexToken t); +#endif +static ffelexHandler ffestb_R8091_ (ffelexToken t); +static ffelexHandler ffestb_R8092_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R8093_ (ffelexToken t); +static ffelexHandler ffestb_R8101_ (ffelexToken t); +static ffelexHandler ffestb_R8102_ (ffelexToken t); +static ffelexHandler ffestb_R8103_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R8104_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R10011_ (ffelexToken t); +static ffelexHandler ffestb_R10012_ (ffelexToken t); +static ffelexHandler ffestb_R10013_ (ffelexToken t); +static ffelexHandler ffestb_R10014_ (ffelexToken t); +static ffelexHandler ffestb_R10015_ (ffelexToken t); +static ffelexHandler ffestb_R10016_ (ffelexToken t); +static ffelexHandler ffestb_R10017_ (ffelexToken t); +static ffelexHandler ffestb_R10018_ (ffelexToken t); +static ffelexHandler ffestb_R10019_ (ffelexToken t); +static ffelexHandler ffestb_R100110_ (ffelexToken t); +static ffelexHandler ffestb_R100111_ (ffelexToken t); +static ffelexHandler ffestb_R100112_ (ffelexToken t); +static ffelexHandler ffestb_R100113_ (ffelexToken t); +static ffelexHandler ffestb_R100114_ (ffelexToken t); +static ffelexHandler ffestb_R100115_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R100116_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R100117_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R100118_ (ffelexToken ft, ffebld expr, + ffelexToken t); +#if FFESTR_F90 +static ffelexHandler ffestb_R11071_ (ffelexToken t); +static ffelexHandler ffestb_R11072_ (ffelexToken t); +static ffelexHandler ffestb_R11073_ (ffelexToken t); +static ffelexHandler ffestb_R11074_ (ffelexToken t); +static ffelexHandler ffestb_R11075_ (ffelexToken t); +static ffelexHandler ffestb_R11076_ (ffelexToken t); +static ffelexHandler ffestb_R11077_ (ffelexToken t); +static ffelexHandler ffestb_R11078_ (ffelexToken t); +static ffelexHandler ffestb_R11079_ (ffelexToken t); +static ffelexHandler ffestb_R110710_ (ffelexToken t); +static ffelexHandler ffestb_R110711_ (ffelexToken t); +static ffelexHandler ffestb_R110712_ (ffelexToken t); +#endif +#if FFESTR_F90 +static ffelexHandler ffestb_R12021_ (ffelexToken t); +static ffelexHandler ffestb_R12022_ (ffelexToken t); +static ffelexHandler ffestb_R12023_ (ffelexToken t); +static ffelexHandler ffestb_R12024_ (ffelexToken t); +static ffelexHandler ffestb_R12025_ (ffelexToken t); +static ffelexHandler ffestb_R12026_ (ffelexToken t); +#endif +static ffelexHandler ffestb_S3P41_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_V0141_ (ffelexToken t); +static ffelexHandler ffestb_V0142_ (ffelexToken t); +static ffelexHandler ffestb_V0143_ (ffelexToken t); +static ffelexHandler ffestb_V0144_ (ffelexToken t); +#if FFESTR_VXT +static ffelexHandler ffestb_V0251_ (ffelexToken t); +static ffelexHandler ffestb_V0252_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_V0253_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_V0254_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_V0255_ (ffelexToken t); +static ffelexHandler ffestb_V0256_ (ffelexToken t); +static ffelexHandler ffestb_V0257_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_V0258_ (ffelexToken t); +#endif +#if FFESTB_KILL_EASY_ +static void ffestb_subr_kill_easy_ (ffestpInquireIx max); +#else +static void ffestb_subr_kill_accept_ (void); +static void ffestb_subr_kill_beru_ (void); +static void ffestb_subr_kill_close_ (void); +static void ffestb_subr_kill_delete_ (void); +static void ffestb_subr_kill_find_ (void); /* Not written yet. */ +static void ffestb_subr_kill_inquire_ (void); +static void ffestb_subr_kill_open_ (void); +static void ffestb_subr_kill_print_ (void); +static void ffestb_subr_kill_read_ (void); +static void ffestb_subr_kill_rewrite_ (void); +static void ffestb_subr_kill_type_ (void); +static void ffestb_subr_kill_vxtcode_ (void); /* Not written yet. */ +static void ffestb_subr_kill_write_ (void); +#endif +static ffelexHandler ffestb_beru1_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_beru2_ (ffelexToken t); +static ffelexHandler ffestb_beru3_ (ffelexToken t); +static ffelexHandler ffestb_beru4_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_beru5_ (ffelexToken t); +static ffelexHandler ffestb_beru6_ (ffelexToken t); +static ffelexHandler ffestb_beru7_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_beru8_ (ffelexToken t); +static ffelexHandler ffestb_beru9_ (ffelexToken t); +static ffelexHandler ffestb_beru10_ (ffelexToken t); +#if FFESTR_VXT +static ffelexHandler ffestb_vxtcode1_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_vxtcode2_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_vxtcode3_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_vxtcode4_ (ffelexToken t); +static ffelexHandler ffestb_vxtcode5_ (ffelexToken t); +static ffelexHandler ffestb_vxtcode6_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_vxtcode7_ (ffelexToken t); +static ffelexHandler ffestb_vxtcode8_ (ffelexToken t); +static ffelexHandler ffestb_vxtcode9_ (ffelexToken t); +static ffelexHandler ffestb_vxtcode10_ (ffelexToken ft, ffebld expr, + ffelexToken t); +#endif +static ffelexHandler ffestb_R9041_ (ffelexToken t); +static ffelexHandler ffestb_R9042_ (ffelexToken t); +static ffelexHandler ffestb_R9043_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R9044_ (ffelexToken t); +static ffelexHandler ffestb_R9045_ (ffelexToken t); +static ffelexHandler ffestb_R9046_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R9047_ (ffelexToken t); +static ffelexHandler ffestb_R9048_ (ffelexToken t); +static ffelexHandler ffestb_R9049_ (ffelexToken t); +static ffelexHandler ffestb_R9071_ (ffelexToken t); +static ffelexHandler ffestb_R9072_ (ffelexToken t); +static ffelexHandler ffestb_R9073_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R9074_ (ffelexToken t); +static ffelexHandler ffestb_R9075_ (ffelexToken t); +static ffelexHandler ffestb_R9076_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R9077_ (ffelexToken t); +static ffelexHandler ffestb_R9078_ (ffelexToken t); +static ffelexHandler ffestb_R9079_ (ffelexToken t); +static ffelexHandler ffestb_R9091_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R9092_ (ffelexToken t); +static ffelexHandler ffestb_R9093_ (ffelexToken t); +static ffelexHandler ffestb_R9094_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R9095_ (ffelexToken t); +static ffelexHandler ffestb_R9096_ (ffelexToken t); +static ffelexHandler ffestb_R9097_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R9098_ (ffelexToken t); +static ffelexHandler ffestb_R9099_ (ffelexToken t); +static ffelexHandler ffestb_R90910_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R90911_ (ffelexToken t); +static ffelexHandler ffestb_R90912_ (ffelexToken t); +static ffelexHandler ffestb_R90913_ (ffelexToken t); +static ffelexHandler ffestb_R90914_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R90915_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R9101_ (ffelexToken t); +static ffelexHandler ffestb_R9102_ (ffelexToken t); +static ffelexHandler ffestb_R9103_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R9104_ (ffelexToken t); +static ffelexHandler ffestb_R9105_ (ffelexToken t); +static ffelexHandler ffestb_R9106_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R9107_ (ffelexToken t); +static ffelexHandler ffestb_R9108_ (ffelexToken t); +static ffelexHandler ffestb_R9109_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R91010_ (ffelexToken t); +static ffelexHandler ffestb_R91011_ (ffelexToken t); +static ffelexHandler ffestb_R91012_ (ffelexToken t); +static ffelexHandler ffestb_R91013_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R91014_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R9111_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R9112_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R9231_ (ffelexToken t); +static ffelexHandler ffestb_R9232_ (ffelexToken t); +static ffelexHandler ffestb_R9233_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R9234_ (ffelexToken t); +static ffelexHandler ffestb_R9235_ (ffelexToken t); +static ffelexHandler ffestb_R9236_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R9237_ (ffelexToken t); +static ffelexHandler ffestb_R9238_ (ffelexToken t); +static ffelexHandler ffestb_R9239_ (ffelexToken t); +static ffelexHandler ffestb_R92310_ (ffelexToken t); +static ffelexHandler ffestb_R92311_ (ffelexToken ft, ffebld expr, + ffelexToken t); +#if FFESTR_VXT +static ffelexHandler ffestb_V0181_ (ffelexToken t); +static ffelexHandler ffestb_V0182_ (ffelexToken t); +static ffelexHandler ffestb_V0183_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_V0184_ (ffelexToken t); +static ffelexHandler ffestb_V0185_ (ffelexToken t); +static ffelexHandler ffestb_V0186_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_V0187_ (ffelexToken t); +static ffelexHandler ffestb_V0188_ (ffelexToken t); +static ffelexHandler ffestb_V0189_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_V01810_ (ffelexToken t); +static ffelexHandler ffestb_V01811_ (ffelexToken t); +static ffelexHandler ffestb_V01812_ (ffelexToken t); +static ffelexHandler ffestb_V01813_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_V0191_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_V0192_ (ffelexToken ft, ffebld expr, + ffelexToken t); +#endif +static ffelexHandler ffestb_V0201_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_V0202_ (ffelexToken ft, ffebld expr, + ffelexToken t); +#if FFESTR_VXT +static ffelexHandler ffestb_V0211_ (ffelexToken t); +static ffelexHandler ffestb_V0212_ (ffelexToken t); +static ffelexHandler ffestb_V0213_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_V0214_ (ffelexToken t); +static ffelexHandler ffestb_V0215_ (ffelexToken t); +static ffelexHandler ffestb_V0216_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_V0217_ (ffelexToken t); +static ffelexHandler ffestb_V0218_ (ffelexToken t); +static ffelexHandler ffestb_V0219_ (ffelexToken t); +static ffelexHandler ffestb_V0261_ (ffelexToken t); +static ffelexHandler ffestb_V0262_ (ffelexToken t); +static ffelexHandler ffestb_V0263_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_V0264_ (ffelexToken t); +static ffelexHandler ffestb_V0265_ (ffelexToken t); +static ffelexHandler ffestb_V0266_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_V0267_ (ffelexToken t); +static ffelexHandler ffestb_V0268_ (ffelexToken t); +static ffelexHandler ffestb_V0269_ (ffelexToken t); +#endif +#if FFESTR_F90 +static ffelexHandler ffestb_dimlist1_ (ffelexToken t); +static ffelexHandler ffestb_dimlist2_ (ffelexToken t); +static ffelexHandler ffestb_dimlist3_ (ffelexToken t); +static ffelexHandler ffestb_dimlist4_ (ffelexToken t); +#endif +static ffelexHandler ffestb_dummy1_ (ffelexToken t); +static ffelexHandler ffestb_dummy2_ (ffelexToken t); +static ffelexHandler ffestb_R5241_ (ffelexToken t); +static ffelexHandler ffestb_R5242_ (ffelexToken t); +static ffelexHandler ffestb_R5243_ (ffelexToken t); +static ffelexHandler ffestb_R5244_ (ffelexToken t); +static ffelexHandler ffestb_R5471_ (ffelexToken t); +static ffelexHandler ffestb_R5472_ (ffelexToken t); +static ffelexHandler ffestb_R5473_ (ffelexToken t); +static ffelexHandler ffestb_R5474_ (ffelexToken t); +static ffelexHandler ffestb_R5475_ (ffelexToken t); +static ffelexHandler ffestb_R5476_ (ffelexToken t); +static ffelexHandler ffestb_R5477_ (ffelexToken t); +#if FFESTR_F90 +static ffelexHandler ffestb_R6241_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_R6242_ (ffelexToken t); +#endif +static ffelexHandler ffestb_R12291_ (ffelexToken t); +static ffelexHandler ffestb_R12292_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_decl_chartype1_ (ffelexToken t); +#if FFESTR_F90 +static ffelexHandler ffestb_decl_recursive1_ (ffelexToken t); +static ffelexHandler ffestb_decl_recursive2_ (ffelexToken t); +static ffelexHandler ffestb_decl_recursive3_ (ffelexToken t); +static ffelexHandler ffestb_decl_recursive4_ (ffelexToken t); +#endif +static ffelexHandler ffestb_decl_attrs_ (ffelexToken t); +static ffelexHandler ffestb_decl_attrs_1_ (ffelexToken t); +static ffelexHandler ffestb_decl_attrs_2_ (ffelexToken t); +#if FFESTR_F90 +static ffelexHandler ffestb_decl_attrs_3_ (ffelexToken t); +static ffelexHandler ffestb_decl_attrs_4_ (ffelexToken t); +static ffelexHandler ffestb_decl_attrs_5_ (ffelexToken t); +static ffelexHandler ffestb_decl_attrs_6_ (ffelexToken t); +#endif +static ffelexHandler ffestb_decl_attrs_7_ (ffelexToken t); +static ffelexHandler ffestb_decl_attrsp_ (ffelexToken t); +static ffelexHandler ffestb_decl_ents_ (ffelexToken t); +static ffelexHandler ffestb_decl_ents_1_ (ffelexToken t); +static ffelexHandler ffestb_decl_ents_2_ (ffelexToken t); +static ffelexHandler ffestb_decl_ents_3_ (ffelexToken t); +static ffelexHandler ffestb_decl_ents_4_ (ffelexToken t); +static ffelexHandler ffestb_decl_ents_5_ (ffelexToken t); +static ffelexHandler ffestb_decl_ents_6_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_decl_ents_7_ (ffelexToken t); +static ffelexHandler ffestb_decl_ents_8_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_decl_ents_9_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_decl_ents_10_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_decl_ents_11_ (ffelexToken t); +static ffelexHandler ffestb_decl_entsp_ (ffelexToken t); +static ffelexHandler ffestb_decl_entsp_1_ (ffelexToken t); +static ffelexHandler ffestb_decl_entsp_2_ (ffelexToken t); +static ffelexHandler ffestb_decl_entsp_3_ (ffelexToken t); +static ffelexHandler ffestb_decl_entsp_4_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_decl_entsp_5_ (ffelexToken t); +static ffelexHandler ffestb_decl_entsp_6_ (ffelexToken t); +static ffelexHandler ffestb_decl_entsp_7_ (ffelexToken t); +static ffelexHandler ffestb_decl_entsp_8_ (ffelexToken t); +#if FFESTR_F90 +static ffelexHandler ffestb_decl_func_ (ffelexToken t); +#endif +static ffelexHandler ffestb_decl_funcname_ (ffelexToken t); +static ffelexHandler ffestb_decl_funcname_1_ (ffelexToken t); +static ffelexHandler ffestb_decl_funcname_2_ (ffelexToken t); +static ffelexHandler ffestb_decl_funcname_3_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_decl_funcname_4_ (ffelexToken t); +static ffelexHandler ffestb_decl_funcname_5_ (ffelexToken t); +static ffelexHandler ffestb_decl_funcname_6_ (ffelexToken t); +static ffelexHandler ffestb_decl_funcname_7_ (ffelexToken t); +static ffelexHandler ffestb_decl_funcname_8_ (ffelexToken t); +static ffelexHandler ffestb_decl_funcname_9_ (ffelexToken t); +#if FFESTR_VXT +static ffelexHandler ffestb_V0031_ (ffelexToken t); +static ffelexHandler ffestb_V0032_ (ffelexToken t); +static ffelexHandler ffestb_V0033_ (ffelexToken t); +static ffelexHandler ffestb_V0034_ (ffelexToken t); +static ffelexHandler ffestb_V0035_ (ffelexToken t); +static ffelexHandler ffestb_V0036_ (ffelexToken t); +static ffelexHandler ffestb_V0161_ (ffelexToken t); +static ffelexHandler ffestb_V0162_ (ffelexToken t); +static ffelexHandler ffestb_V0163_ (ffelexToken t); +static ffelexHandler ffestb_V0164_ (ffelexToken t); +static ffelexHandler ffestb_V0165_ (ffelexToken t); +static ffelexHandler ffestb_V0166_ (ffelexToken t); +#endif +static ffelexHandler ffestb_V0271_ (ffelexToken t); +static ffelexHandler ffestb_V0272_ (ffelexToken ft, ffebld expr, + ffelexToken t); +static ffelexHandler ffestb_V0273_ (ffelexToken t); +static ffelexHandler ffestb_decl_R5391_ (ffelexToken t); +static ffelexHandler ffestb_decl_R5392_ (ffelexToken t); +#if FFESTR_F90 +static ffelexHandler ffestb_decl_R5393_ (ffelexToken t); +#endif +static ffelexHandler ffestb_decl_R5394_ (ffelexToken t); +static ffelexHandler ffestb_decl_R5395_ (ffelexToken t); +static ffelexHandler ffestb_decl_R539letters_ (ffelexToken t); +static ffelexHandler ffestb_decl_R539letters_1_ (ffelexToken t); +static ffelexHandler ffestb_decl_R539letters_2_ (ffelexToken t); +static ffelexHandler ffestb_decl_R539letters_3_ (ffelexToken t); +static ffelexHandler ffestb_decl_R539letters_4_ (ffelexToken t); +static ffelexHandler ffestb_decl_R539letters_5_ (ffelexToken t); +static ffelexHandler ffestb_decl_R539maybe_ (ffelexToken t); +static ffelexHandler ffestb_decl_R539maybe_1_ (ffelexToken t); +static ffelexHandler ffestb_decl_R539maybe_2_ (ffelexToken t); +static ffelexHandler ffestb_decl_R539maybe_3_ (ffelexToken t); +static ffelexHandler ffestb_decl_R539maybe_4_ (ffelexToken t); +static ffelexHandler ffestb_decl_R539maybe_5_ (ffelexToken t); + +/* Internal macros. */ + +#if FFESTB_KILL_EASY_ +#define ffestb_subr_kill_accept_() \ + ffestb_subr_kill_easy_((ffestpInquireIx) FFESTP_acceptix) +#define ffestb_subr_kill_beru_() \ + ffestb_subr_kill_easy_((ffestpInquireIx) FFESTP_beruix) +#define ffestb_subr_kill_close_() \ + ffestb_subr_kill_easy_((ffestpInquireIx) FFESTP_closeix) +#define ffestb_subr_kill_delete_() \ + ffestb_subr_kill_easy_((ffestpInquireIx) FFESTP_deleteix) +#define ffestb_subr_kill_find_() \ + ffestb_subr_kill_easy_((ffestpInquireIx) FFESTP_findix) +#define ffestb_subr_kill_inquire_() \ + ffestb_subr_kill_easy_((ffestpInquireIx) FFESTP_inquireix) +#define ffestb_subr_kill_open_() \ + ffestb_subr_kill_easy_((ffestpInquireIx) FFESTP_openix) +#define ffestb_subr_kill_print_() \ + ffestb_subr_kill_easy_((ffestpInquireIx) FFESTP_printix) +#define ffestb_subr_kill_read_() \ + ffestb_subr_kill_easy_((ffestpInquireIx) FFESTP_readix) +#define ffestb_subr_kill_rewrite_() \ + ffestb_subr_kill_easy_((ffestpInquireIx) FFESTP_rewriteix) +#define ffestb_subr_kill_type_() \ + ffestb_subr_kill_easy_((ffestpInquireIx) FFESTP_typeix) +#define ffestb_subr_kill_vxtcode_() \ + ffestb_subr_kill_easy_((ffestpInquireIx) FFESTP_vxtcodeix) +#define ffestb_subr_kill_write_() \ + ffestb_subr_kill_easy_((ffestpInquireIx) FFESTP_writeix) +#endif + +/* ffestb_subr_ambig_nope_ -- Cleans up and aborts ambig w/o confirming + + ffestb_subr_ambig_nope_(); + + Switch from ambiguity handling in _entsp_ functions to handling entities + in _ents_ (perform housekeeping tasks). */ + +static ffelexHandler +ffestb_subr_ambig_nope_ (ffelexToken t) +{ + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffestt_tokenlist_kill (ffestb_local_.decl.toklist); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_subr_ambig_to_ents_ -- Switches from ambiguity to entity decl + + ffestb_subr_ambig_to_ents_(); + + Switch from ambiguity handling in _entsp_ functions to handling entities + in _ents_ (perform housekeeping tasks). */ + +static void +ffestb_subr_ambig_to_ents_ () +{ + ffelexToken nt; + + nt = ffelex_token_name_from_names (ffesta_tokens[1], 0, 0); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffesta_tokens[1] = nt; + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (!ffestb_local_.decl.aster_after) + { + if (ffestb_local_.decl.type == FFESTP_typeCHARACTER) + { + if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + ffestb_local_.decl.kind, ffestb_local_.decl.kindt, + ffestb_local_.decl.len, ffestb_local_.decl.lent); + if (ffestb_local_.decl.kindt != NULL) + { + ffelex_token_kill (ffestb_local_.decl.kindt); + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + } + if (ffestb_local_.decl.lent != NULL) + { + ffelex_token_kill (ffestb_local_.decl.lent); + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + } + } + else + { + if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + ffestb_local_.decl.kind, ffestb_local_.decl.kindt, NULL, + NULL); + if (ffestb_local_.decl.kindt != NULL) + { + ffelex_token_kill (ffestb_local_.decl.kindt); + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + } + } + return; + } + if (ffestb_local_.decl.type == FFESTP_typeCHARACTER) + { + if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + ffestb_local_.decl.kind, ffestb_local_.decl.kindt, NULL, NULL); + if (ffestb_local_.decl.kindt != NULL) + { + ffelex_token_kill (ffestb_local_.decl.kindt); + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + } + } + else if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + NULL, NULL, NULL, NULL); + /* NAME/NAMES token already in ffesta_tokens[1]. */ +} + +/* ffestb_subr_dimlist_ -- OPEN_PAREN expr + + (ffestb_subr_dimlist_) // to expression handler + + Deal with a dimension list. + + 19-Dec-90 JCB 1.1 + Detect too many dimensions if backend wants it. */ + +static ffelexHandler +ffestb_subr_dimlist_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; +#ifdef FFECOM_dimensionsMAX + if (ffestb_subrargs_.dim_list.ndims++ == FFECOM_dimensionsMAX) + { + ffesta_ffebad_1t (FFEBAD_TOO_MANY_DIMS, ft); + ffestb_subrargs_.dim_list.ok = TRUE; /* Not a parse error, really. */ + return (ffelexHandler) ffestb_subrargs_.dim_list.handler; + } +#endif + ffestt_dimlist_append (ffestb_subrargs_.dim_list.dims, NULL, expr, + ffelex_token_use (t)); + ffestb_subrargs_.dim_list.ok = TRUE; + return (ffelexHandler) ffestb_subrargs_.dim_list.handler; + + case FFELEX_typeCOMMA: + if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR)) + break; +#ifdef FFECOM_dimensionsMAX + if (ffestb_subrargs_.dim_list.ndims++ == FFECOM_dimensionsMAX) + { + ffesta_ffebad_1t (FFEBAD_TOO_MANY_DIMS, ft); + return (ffelexHandler) ffeexpr_rhs (ffestb_subrargs_.dim_list.pool, + ffestb_subrargs_.dim_list.ctx, + (ffeexprCallback) ffestb_subr_dimlist_2_); + } +#endif + ffestt_dimlist_append (ffestb_subrargs_.dim_list.dims, NULL, expr, + ffelex_token_use (t)); + return (ffelexHandler) ffeexpr_rhs (ffestb_subrargs_.dim_list.pool, + ffestb_subrargs_.dim_list.ctx, + (ffeexprCallback) ffestb_subr_dimlist_); + + case FFELEX_typeCOLON: + if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR)) + break; +#ifdef FFECOM_dimensionsMAX + if (ffestb_subrargs_.dim_list.ndims++ == FFECOM_dimensionsMAX) + { + ffesta_ffebad_1t (FFEBAD_TOO_MANY_DIMS, ft); + return (ffelexHandler) ffeexpr_rhs (ffestb_subrargs_.dim_list.pool, + ffestb_subrargs_.dim_list.ctx, + (ffeexprCallback) ffestb_subr_dimlist_2_); + } +#endif + ffestt_dimlist_append (ffestb_subrargs_.dim_list.dims, expr, NULL, + ffelex_token_use (t)); /* NULL second expr for + now, just plug in. */ + return (ffelexHandler) ffeexpr_rhs (ffestb_subrargs_.dim_list.pool, + ffestb_subrargs_.dim_list.ctx, + (ffeexprCallback) ffestb_subr_dimlist_1_); + + default: + break; + } + + ffestb_subrargs_.dim_list.ok = FALSE; + return (ffelexHandler) ffestb_subrargs_.dim_list.handler (t); +} + +/* ffestb_subr_dimlist_1_ -- OPEN_PAREN expr COLON expr + + (ffestb_subr_dimlist_1_) // to expression handler + + Get the upper bound. */ + +static ffelexHandler +ffestb_subr_dimlist_1_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + ffestb_subrargs_.dim_list.dims->previous->upper = expr; + ffestb_subrargs_.dim_list.ok = TRUE; + return (ffelexHandler) ffestb_subrargs_.dim_list.handler; + + case FFELEX_typeCOMMA: + if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR)) + break; + ffestb_subrargs_.dim_list.dims->previous->upper = expr; + return (ffelexHandler) ffeexpr_rhs (ffestb_subrargs_.dim_list.pool, + ffestb_subrargs_.dim_list.ctx, (ffeexprCallback) ffestb_subr_dimlist_); + + default: + break; + } + + ffestb_subrargs_.dim_list.ok = FALSE; + return (ffelexHandler) ffestb_subrargs_.dim_list.handler (t); +} + +/* ffestb_subr_dimlist_2_ -- OPEN_PAREN too-many-dim-exprs + + (ffestb_subr_dimlist_2_) // to expression handler + + Get the upper bound. */ + +static ffelexHandler +ffestb_subr_dimlist_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + ffestb_subrargs_.dim_list.ok = TRUE; /* Not a parse error, really. */ + return (ffelexHandler) ffestb_subrargs_.dim_list.handler; + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLON: + if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR)) + break; + return (ffelexHandler) ffeexpr_rhs (ffestb_subrargs_.dim_list.pool, + ffestb_subrargs_.dim_list.ctx, + (ffeexprCallback) ffestb_subr_dimlist_2_); + + default: + break; + } + + ffestb_subrargs_.dim_list.ok = FALSE; + return (ffelexHandler) ffestb_subrargs_.dim_list.handler (t); +} + +/* ffestb_subr_name_list_ -- Collect a list of name args and close-paren + + return ffestb_subr_name_list_; // to lexer after seeing OPEN_PAREN + + This implements R1224 in the Fortran 90 spec. The arg list may be + empty, or be a comma-separated list (an optional trailing comma currently + results in a warning but no other effect) of arguments. For functions, + however, "*" is invalid (we implement dummy-arg-name, rather than R1224 + dummy-arg, which itself is either dummy-arg-name or "*"). */ + +static ffelexHandler +ffestb_subr_name_list_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + if (ffestt_tokenlist_count (ffestb_subrargs_.name_list.args) != 0) + { /* Trailing comma, warn. */ + ffebad_start (FFEBAD_TRAILING_COMMA); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + ffestb_subrargs_.name_list.ok = TRUE; + ffestb_subrargs_.name_list.close_paren = ffelex_token_use (t); + if (ffestb_subrargs_.name_list.names) + ffelex_set_names (TRUE); + return (ffelexHandler) ffestb_subrargs_.name_list.handler; + + case FFELEX_typeASTERISK: + if (!ffestb_subrargs_.name_list.is_subr) + break; + + case FFELEX_typeNAME: + ffestt_tokenlist_append (ffestb_subrargs_.name_list.args, + ffelex_token_use (t)); + return (ffelexHandler) ffestb_subr_name_list_1_; + + default: + break; + } + + ffestb_subrargs_.name_list.ok = FALSE; + ffestb_subrargs_.name_list.close_paren = ffelex_token_use (t); + if (ffestb_subrargs_.name_list.names) + ffelex_set_names (TRUE); + return (ffelexHandler) (*ffestb_subrargs_.name_list.handler) (t); +} + +/* ffestb_subr_name_list_1_ -- NAME or ASTERISK + + return ffestb_subr_name_list_1_; // to lexer + + The next token must be COMMA or CLOSE_PAREN, either way go to original + state, but only after adding the appropriate name list item. */ + +static ffelexHandler +ffestb_subr_name_list_1_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_subr_name_list_; + + case FFELEX_typeCLOSE_PAREN: + ffestb_subrargs_.name_list.ok = TRUE; + ffestb_subrargs_.name_list.close_paren = ffelex_token_use (t); + if (ffestb_subrargs_.name_list.names) + ffelex_set_names (TRUE); + return (ffelexHandler) ffestb_subrargs_.name_list.handler; + + default: + ffestb_subrargs_.name_list.ok = FALSE; + ffestb_subrargs_.name_list.close_paren = ffelex_token_use (t); + if (ffestb_subrargs_.name_list.names) + ffelex_set_names (TRUE); + return (ffelexHandler) (*ffestb_subrargs_.name_list.handler) (t); + } +} + +static void +ffestb_subr_R1001_append_p_ (void) +{ + ffesttFormatList f; + + if (!ffestb_local_.format.pre.present) + { + ffesta_ffebad_1t (FFEBAD_FORMAT_BAD_P_SPEC, ffestb_local_.format.t); + ffelex_token_kill (ffestb_local_.format.t); + return; + } + + f = ffestt_formatlist_append (ffestb_local_.format.f); + f->type = FFESTP_formattypeP; + f->t = ffestb_local_.format.t; + f->u.R1010.val = ffestb_local_.format.pre; +} + +/* ffestb_decl_kindparam_ -- "type" OPEN_PAREN + + return ffestb_decl_kindparam_; // to lexer + + Handle "[KIND=]expr)". */ + +static ffelexHandler +ffestb_decl_kindparam_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_decl_kindparam_1_; + + default: + return (ffelexHandler) (*((ffelexHandler) + ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextKINDTYPE, + (ffeexprCallback) ffestb_decl_kindparam_2_))) + (t); + } +} + +/* ffestb_decl_kindparam_1_ -- "type" OPEN_PAREN NAME + + return ffestb_decl_kindparam_1_; // to lexer + + Handle "[KIND=]expr)". */ + +static ffelexHandler +ffestb_decl_kindparam_1_ (ffelexToken t) +{ + ffelexHandler next; + ffelexToken nt; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + ffesta_confirmed (); + if (ffestr_other (ffesta_tokens[1]) != FFESTR_otherKIND) + break; + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextKINDTYPE, (ffeexprCallback) ffestb_decl_kindparam_2_); + + default: + nt = ffesta_tokens[1]; + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextKINDTYPE, (ffeexprCallback) ffestb_decl_kindparam_2_))) + (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, + ffestb_local_.decl.badname, + ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_kindparam_2_ -- "type" OPEN_PAREN ["KIND="] expr + + (ffestb_decl_kindparam_2_) // to expression handler + + Handle "[KIND=]expr)". */ + +static ffelexHandler +ffestb_decl_kindparam_2_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + ffestb_local_.decl.kind = expr; + ffestb_local_.decl.kindt = ffelex_token_use (ft); + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + ffelex_set_names (TRUE); + return (ffelexHandler) ffestb_local_.decl.handler; + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, + ffestb_local_.decl.badname, + t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_starkind_ -- "type" ASTERISK + + return ffestb_decl_starkind_; // to lexer + + Handle NUMBER. */ + +static ffelexHandler +ffestb_decl_starkind_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + ffestb_local_.decl.kindt = ffelex_token_use (t); + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + ffelex_set_names (TRUE); + return (ffelexHandler) ffestb_local_.decl.handler; + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, + ffestb_local_.decl.badname, + t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_starlen_ -- "CHARACTER" ASTERISK + + return ffestb_decl_starlen_; // to lexer + + Handle NUMBER. */ + +static ffelexHandler +ffestb_decl_starlen_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = ffelex_token_use (t); + ffelex_set_names (TRUE); + return (ffelexHandler) ffestb_local_.decl.handler; + + case FFELEX_typeOPEN_PAREN: + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextCHARACTERSIZE, + (ffeexprCallback) ffestb_decl_starlen_1_); + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, + ffestb_local_.decl.badname, + t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_starlen_1_ -- "CHARACTER" ASTERISK OPEN_PAREN expr + + (ffestb_decl_starlen_1_) // to expression handler + + Handle CLOSE_PAREN. */ + +static ffelexHandler +ffestb_decl_starlen_1_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestb_local_.decl.len = expr; + ffestb_local_.decl.lent = ffelex_token_use (ft); + ffelex_set_names (TRUE); + return (ffelexHandler) ffestb_local_.decl.handler; + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, + ffestb_local_.decl.badname, + t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_typeparams_ -- "CHARACTER" OPEN_PAREN + + return ffestb_decl_typeparams_; // to lexer + + Handle "[KIND=]expr)". */ + +static ffelexHandler +ffestb_decl_typeparams_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_decl_typeparams_1_; + + default: + if (ffestb_local_.decl.lent == NULL) + return (ffelexHandler) (*((ffelexHandler) + ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextCHARACTERSIZE, + (ffeexprCallback) ffestb_decl_typeparams_2_))) + (t); + if (ffestb_local_.decl.kindt != NULL) + break; + return (ffelexHandler) (*((ffelexHandler) + ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextKINDTYPE, + (ffeexprCallback) ffestb_decl_typeparams_3_))) + (t); + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, + ffestb_local_.decl.badname, + t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_typeparams_1_ -- "CHARACTER" OPEN_PAREN NAME + + return ffestb_decl_typeparams_1_; // to lexer + + Handle "[KIND=]expr)". */ + +static ffelexHandler +ffestb_decl_typeparams_1_ (ffelexToken t) +{ + ffelexHandler next; + ffelexToken nt; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + ffesta_confirmed (); + switch (ffestr_other (ffesta_tokens[1])) + { + case FFESTR_otherLEN: + if (ffestb_local_.decl.lent != NULL) + break; + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextCHARACTERSIZE, + (ffeexprCallback) ffestb_decl_typeparams_2_); + + case FFESTR_otherKIND: + if (ffestb_local_.decl.kindt != NULL) + break; + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextKINDTYPE, + (ffeexprCallback) ffestb_decl_typeparams_3_); + + default: + break; + } + break; + + default: + nt = ffesta_tokens[1]; + if (ffestb_local_.decl.lent == NULL) + next = (ffelexHandler) (*((ffelexHandler) + ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextCHARACTERSIZE, + (ffeexprCallback) ffestb_decl_typeparams_2_))) + (nt); + else if (ffestb_local_.decl.kindt == NULL) + next = (ffelexHandler) (*((ffelexHandler) + ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextKINDTYPE, + (ffeexprCallback) ffestb_decl_typeparams_3_))) + (nt); + else + { + ffesta_tokens[1] = nt; + break; + } + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, + ffestb_local_.decl.badname, + ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_typeparams_2_ -- "CHARACTER" OPEN_PAREN ["LEN="] expr + + (ffestb_decl_typeparams_2_) // to expression handler + + Handle "[LEN=]expr)". */ + +static ffelexHandler +ffestb_decl_typeparams_2_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + ffestb_local_.decl.len = expr; + ffestb_local_.decl.lent = ffelex_token_use (ft); + ffelex_set_names (TRUE); + return (ffelexHandler) ffestb_local_.decl.handler; + + case FFELEX_typeCOMMA: + ffestb_local_.decl.len = expr; + ffestb_local_.decl.lent = ffelex_token_use (ft); + return (ffelexHandler) ffestb_decl_typeparams_; + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, + ffestb_local_.decl.badname, + t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_typeparams_3_ -- "CHARACTER" OPEN_PAREN ["KIND="] expr + + (ffestb_decl_typeparams_3_) // to expression handler + + Handle "[KIND=]expr)". */ + +static ffelexHandler +ffestb_decl_typeparams_3_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + ffestb_local_.decl.kind = expr; + ffestb_local_.decl.kindt = ffelex_token_use (ft); + ffelex_set_names (TRUE); + return (ffelexHandler) ffestb_local_.decl.handler; + + case FFELEX_typeCOMMA: + ffestb_local_.decl.kind = expr; + ffestb_local_.decl.kindt = ffelex_token_use (ft); + return (ffelexHandler) ffestb_decl_typeparams_; + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, + ffestb_local_.decl.badname, + t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_typetype1_ -- "TYPE" OPEN_PAREN + + return ffestb_decl_typetype1_; // to lexer + + Handle NAME. */ + +#if FFESTR_F90 +static ffelexHandler +ffestb_decl_typetype1_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffestb_local_.decl.kindt = ffelex_token_use (t); + return (ffelexHandler) ffestb_decl_typetype2_; + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, + ffestb_local_.decl.badname, + t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_typetype2_ -- "TYPE" OPEN_PAREN NAME + + return ffestb_decl_typetype2_; // to lexer + + Handle CLOSE_PAREN. */ + +static ffelexHandler +ffestb_decl_typetype2_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + ffestb_local_.decl.type = FFESTP_typeTYPE; + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + ffelex_set_names (TRUE); + return (ffelexHandler) ffestb_local_.decl.handler; + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + ffelex_token_kill (ffestb_local_.decl.kindt); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, + ffestb_local_.decl.badname, + t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_subr_label_list_ -- Collect a tokenlist of labels and close-paren + + return ffestb_subr_label_list_; // to lexer after seeing OPEN_PAREN + + First token must be a NUMBER. Must be followed by zero or more COMMA + NUMBER pairs. Must then be followed by a CLOSE_PAREN. If all ok, put + the NUMBER tokens in a token list and return via the handler for the + token after CLOSE_PAREN. Else return via + same handler, but with the ok return value set FALSE. */ + +static ffelexHandler +ffestb_subr_label_list_ (ffelexToken t) +{ + if (ffelex_token_type (t) == FFELEX_typeNUMBER) + { + ffestt_tokenlist_append (ffestb_subrargs_.label_list.labels, + ffelex_token_use (t)); + return (ffelexHandler) ffestb_subr_label_list_1_; + } + + ffestb_subrargs_.label_list.ok = FALSE; + return (ffelexHandler) (*ffestb_subrargs_.label_list.handler) (t); +} + +/* ffestb_subr_label_list_1_ -- NUMBER + + return ffestb_subr_label_list_1_; // to lexer after seeing NUMBER + + The next token must be COMMA, in which case go back to + ffestb_subr_label_list_, or CLOSE_PAREN, in which case set ok to TRUE + and go to the handler. */ + +static ffelexHandler +ffestb_subr_label_list_1_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_subr_label_list_; + + case FFELEX_typeCLOSE_PAREN: + ffestb_subrargs_.label_list.ok = TRUE; + return (ffelexHandler) ffestb_subrargs_.label_list.handler; + + default: + ffestb_subrargs_.label_list.ok = FALSE; + return (ffelexHandler) (*ffestb_subrargs_.label_list.handler) (t); + } +} + +/* ffestb_do -- Parse the DO statement + + return ffestb_do; // to lexer + + Make sure the statement has a valid form for the DO statement. If it + does, implement the statement. */ + +ffelexHandler +ffestb_do (ffelexToken t) +{ + ffeTokenLength i; + char *p; + ffelexHandler next; + ffelexToken nt; + ffestrSecond kw; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstDO) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + ffesta_confirmed (); + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_do1_; + + case FFELEX_typeCOMMA: + ffesta_confirmed (); + ffesta_tokens[1] = NULL; + return (ffelexHandler) ffestb_do2_; + + case FFELEX_typeNAME: + ffesta_confirmed (); + ffesta_tokens[1] = NULL; + ffesta_tokens[2] = ffelex_token_use (t); + return (ffelexHandler) ffestb_do3_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + ffesta_tokens[1] = NULL; + return (ffelexHandler) ffestb_do1_ (t); + + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstDO) + goto bad_0; /* :::::::::::::::::::: */ + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlDO); + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: /* Must be "DO" label "WHILE". */ + if (!isdigit (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffesta_tokens[1] = ffelex_token_number_from_names (ffesta_tokens[0], + i); + p += ffelex_token_length (ffesta_tokens[1]); + i += ffelex_token_length (ffesta_tokens[1]); + if (((*p) != 'W') && ((*p) != 'w')) + goto bad_i1; /* :::::::::::::::::::: */ + nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + kw = ffestr_second (nt); + ffelex_token_kill (nt); + if (kw != FFESTR_secondWHILE) + goto bad_i1; /* :::::::::::::::::::: */ + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextDOWHILE, (ffeexprCallback) ffestb_do4_); + + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (*p == '\0') + { + ffesta_tokens[1] = NULL; + return (ffelexHandler) ffestb_do2_; + } + if (!isdigit (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffesta_tokens[1] = ffelex_token_number_from_names (ffesta_tokens[0], + i); + p += ffelex_token_length (ffesta_tokens[1]); + i += ffelex_token_length (ffesta_tokens[1]); + if (*p != '\0') + goto bad_i1; /* :::::::::::::::::::: */ + return (ffelexHandler) ffestb_do2_; + + case FFELEX_typeEQUALS: + if (isdigit (*p)) + { + ffesta_tokens[1] + = ffelex_token_number_from_names (ffesta_tokens[0], i); + p += ffelex_token_length (ffesta_tokens[1]); + i += ffelex_token_length (ffesta_tokens[1]); + } + else + ffesta_tokens[1] = NULL; + if (!ffesrc_is_name_init (*p)) + goto bad_i1; /* :::::::::::::::::::: */ + nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_lhs + (ffesta_output_pool, FFEEXPR_contextDO, + (ffeexprCallback) ffestb_do6_))) + (nt); + ffelex_token_kill (nt); /* Will get it back in _6_... */ + return (ffelexHandler) (*next) (t); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (isdigit (*p)) + { + ffesta_tokens[1] + = ffelex_token_number_from_names (ffesta_tokens[0], i); + p += ffelex_token_length (ffesta_tokens[1]); + i += ffelex_token_length (ffesta_tokens[1]); + } + else + ffesta_tokens[1] = NULL; + if (*p != '\0') + goto bad_i1; /* :::::::::::::::::::: */ + return (ffelexHandler) ffestb_do1_ (t); + } + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DO", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DO", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i1: /* :::::::::::::::::::: */ + if (ffesta_tokens[1]) + ffelex_token_kill (ffesta_tokens[1]); + +bad_i: /* :::::::::::::::::::: */ + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "DO", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_dowhile -- Parse the DOWHILE statement + + return ffestb_dowhile; // to lexer + + Make sure the statement has a valid form for the DOWHILE statement. If it + does, implement the statement. */ + +ffelexHandler +ffestb_dowhile (ffelexToken t) +{ + ffeTokenLength i; + char *p; + ffelexHandler next; + ffelexToken nt; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstDOWHILE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlDOWHILE); + if (*p != '\0') + goto bad_i; /* :::::::::::::::::::: */ + ffesta_tokens[1] = NULL; + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextDOWHILE, (ffeexprCallback) ffestb_do4_); + + case FFELEX_typeEQUALS:/* Not really DOWHILE, but DOWHILExyz=.... */ + ffesta_tokens[1] = NULL; + nt = ffelex_token_name_from_names (ffesta_tokens[0], FFESTR_firstlDO, + 0); + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_lhs + (ffesta_output_pool, FFEEXPR_contextDO, + (ffeexprCallback) ffestb_do6_))) + (nt); + ffelex_token_kill (nt); /* Will get it back in _6_... */ + return (ffelexHandler) (*next) (t); + } + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DO", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DO", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "DO", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_do1_ -- "DO" [label] + + return ffestb_do1_; // to lexer + + Make sure the statement has a valid form for the DO statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_do1_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffesta_confirmed (); + return (ffelexHandler) ffestb_do2_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + if (ffesta_tokens[1] != NULL) + ffestc_R819B (ffesta_construct_name, ffesta_tokens[1], NULL, + NULL); + else + ffestc_R820B (ffesta_construct_name, NULL, NULL); + } + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeNAME: + return (ffelexHandler) ffestb_do2_ (t); + + default: + break; + } + + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DO", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_do2_ -- "DO" [label] [,] + + return ffestb_do2_; // to lexer + + Make sure the statement has a valid form for the DO statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_do2_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[2] = ffelex_token_use (t); + return (ffelexHandler) ffestb_do3_; + + default: + break; + } + + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DO", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_do3_ -- "DO" [label] [,] NAME + + return ffestb_do3_; // to lexer + + Make sure the statement has a valid form for the DO statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_do3_ (ffelexToken t) +{ + ffelexHandler next; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextDO, (ffeexprCallback) ffestb_do6_))) + (ffesta_tokens[2]); + ffelex_token_kill (ffesta_tokens[2]); /* Will get it back in _6_... */ + return (ffelexHandler) (*next) (t); + + case FFELEX_typeOPEN_PAREN: + if (ffestr_second (ffesta_tokens[2]) != FFESTR_secondWHILE) + { + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DO", ffesta_tokens[2]); + ffelex_token_kill (ffesta_tokens[2]); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid token. */ + } + ffelex_token_kill (ffesta_tokens[2]); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextDOWHILE, (ffeexprCallback) ffestb_do4_); + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[2]); + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DO", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_do4_ -- "DO" [label] [,] "WHILE" OPEN_PAREN expr + + (ffestb_do4_) // to expression handler + + Make sure the statement has a valid form for the DO statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_do4_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffesta_tokens[2] = ffelex_token_use (ft); + ffestb_local_.dowhile.expr = expr; + return (ffelexHandler) ffestb_do5_; + + default: + break; + } + + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DO", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_do5_ -- "DO" [label] [,] "WHILE" OPEN_PAREN expr CLOSE_PAREN + + return ffestb_do5_; // to lexer + + Make sure the statement has a valid form for the DO statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_do5_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + if (ffesta_tokens[1] != NULL) + ffestc_R819B (ffesta_construct_name, ffesta_tokens[1], + ffestb_local_.dowhile.expr, ffesta_tokens[2]); + else + ffestc_R820B (ffesta_construct_name, ffestb_local_.dowhile.expr, + ffesta_tokens[2]); + } + ffelex_token_kill (ffesta_tokens[2]); + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[2]); + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DO", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_do6_ -- "DO" [label] [,] var-expr + + (ffestb_do6_) // to expression handler + + Make sure the statement has a valid form for the DO statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_do6_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + /* _3_ already ensured that this would be an EQUALS token. If not, it is a + bug in the FFE. */ + + assert (ffelex_token_type (t) == FFELEX_typeEQUALS); + + ffesta_tokens[2] = ffelex_token_use (ft); + ffestb_local_.do_stmt.var = expr; + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextDO, (ffeexprCallback) ffestb_do7_); +} + +/* ffestb_do7_ -- "DO" [label] [,] var-expr EQUALS expr + + (ffestb_do7_) // to expression handler + + Make sure the statement has a valid form for the DO statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_do7_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (expr == NULL) + break; + ffesta_tokens[3] = ffelex_token_use (ft); + ffestb_local_.do_stmt.start = expr; + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextDO, (ffeexprCallback) ffestb_do8_); + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[2]); + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DO", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_do8_ -- "DO" [label] [,] var-expr EQUALS expr COMMA expr + + (ffestb_do8_) // to expression handler + + Make sure the statement has a valid form for the DO statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_do8_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + ffesta_tokens[4] = ffelex_token_use (ft); + ffestb_local_.do_stmt.end = expr; + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextDO, (ffeexprCallback) ffestb_do9_); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (expr == NULL) + break; + ffesta_tokens[4] = ffelex_token_use (ft); + ffestb_local_.do_stmt.end = expr; + return (ffelexHandler) ffestb_do9_ (NULL, NULL, t); + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[3]); + ffelex_token_kill (ffesta_tokens[2]); + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DO", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_do9_ -- "DO" [label] [,] var-expr EQUALS expr COMMA expr + [COMMA expr] + + (ffestb_do9_) // to expression handler + + Make sure the statement has a valid form for the DO statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_do9_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if ((expr == NULL) && (ft != NULL)) + break; + if (!ffesta_is_inhibited ()) + { + if (ffesta_tokens[1] != NULL) + ffestc_R819A (ffesta_construct_name, ffesta_tokens[1], + ffestb_local_.do_stmt.var, ffesta_tokens[2], + ffestb_local_.do_stmt.start, ffesta_tokens[3], + ffestb_local_.do_stmt.end, ffesta_tokens[4], expr, ft); + else + ffestc_R820A (ffesta_construct_name, ffestb_local_.do_stmt.var, + ffesta_tokens[2], ffestb_local_.do_stmt.start, + ffesta_tokens[3], ffestb_local_.do_stmt.end, + ffesta_tokens[4], expr, ft); + } + ffelex_token_kill (ffesta_tokens[4]); + ffelex_token_kill (ffesta_tokens[3]); + ffelex_token_kill (ffesta_tokens[2]); + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[4]); + ffelex_token_kill (ffesta_tokens[3]); + ffelex_token_kill (ffesta_tokens[2]); + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DO", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_else -- Parse the ELSE statement + + return ffestb_else; // to lexer + + Make sure the statement has a valid form for the ELSE statement. If it + does, implement the statement. */ + +ffelexHandler +ffestb_else (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstELSE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + ffesta_tokens[1] = NULL; + ffestb_args.elsexyz.second = FFESTR_secondNone; + return (ffelexHandler) ffestb_else1_ (t); + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + break; + } + + ffesta_confirmed (); + ffestb_args.elsexyz.second = ffesta_second_kw; + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_else1_; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstELSE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + } + ffesta_confirmed (); + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlELSE) + { + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlELSE); + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffesta_tokens[1] + = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + } + else + ffesta_tokens[1] = NULL; + ffestb_args.elsexyz.second = FFESTR_secondNone; + return (ffelexHandler) ffestb_else1_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ELSE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ELSE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "ELSE", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_elsexyz -- Parse an ELSEIF/ELSEWHERE statement + + return ffestb_elsexyz; // to lexer + + Expects len and second to be set in ffestb_args.elsexyz to the length + of the ELSExyz keyword involved and the corresponding ffestrSecond value. */ + +ffelexHandler +ffestb_elsexyz (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (ffesta_first_kw == FFESTR_firstELSEIF) + goto bad_0; /* :::::::::::::::::::: */ + ffesta_confirmed (); + ffesta_tokens[1] = NULL; + return (ffelexHandler) ffestb_else1_ (t); + + case FFELEX_typeNAME: + ffesta_confirmed (); + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + if (ffesta_first_kw != FFESTR_firstELSEIF) + goto bad_0; /* :::::::::::::::::::: */ + ffesta_tokens[1] = NULL; + return (ffelexHandler) ffestb_else1_ (t); + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + case FFELEX_typeNAMES: + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + if (ffesta_first_kw != FFESTR_firstELSEIF) + goto bad_1; /* :::::::::::::::::::: */ + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlELSEIF) + { + i = FFESTR_firstlELSEIF; + goto bad_i; /* :::::::::::::::::::: */ + } + ffesta_tokens[1] = NULL; + return (ffelexHandler) ffestb_else1_ (t); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + } + ffesta_confirmed (); + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlELSE); + ffesta_tokens[1] + = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); +#if FFESTR_F90 + if ((ffestb_args.elsexyz.second == FFESTR_secondWHERE) + && (ffelex_token_length (ffesta_tokens[1]) != FFESTR_secondlWHERE)) + ffestb_args.elsexyz.second = FFESTR_secondNone; +#endif + return (ffelexHandler) ffestb_else1_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ELSE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ELSE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "ELSE IF", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_else1_ -- "ELSE" (NAME) + + return ffestb_else1_; // to lexer + + If EOS/SEMICOLON, implement the appropriate statement (keep in mind that + "ELSE WHERE" is ambiguous at the syntactic level). If OPEN_PAREN, start + expression analysis with callback at _2_. */ + +static ffelexHandler +ffestb_else1_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + if (ffestb_args.elsexyz.second == FFESTR_secondIF) + { + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextIF, (ffeexprCallback) ffestb_else2_); + } + /* Fall through. */ + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ELSE", t); + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + break; + + } + + switch (ffestb_args.elsexyz.second) + { +#if FFESTR_F90 + case FFESTR_secondWHERE: + if (!ffesta_is_inhibited ()) + if ((ffesta_first_kw == FFESTR_firstELSEWHERE) + && (ffelex_token_type (ffesta_tokens[0]) == FFELEX_typeNAME)) + ffestc_R744 (); + else + ffestc_elsewhere (ffesta_tokens[1]); /* R744 or R805. */ + break; +#endif + + default: + if (!ffesta_is_inhibited ()) + ffestc_R805 (ffesta_tokens[1]); + break; + } + + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); +} + +/* ffestb_else2_ -- "ELSE" "IF" OPEN_PAREN expr + + (ffestb_else2_) // to expression handler + + Make sure the next token is CLOSE_PAREN. */ + +static ffelexHandler +ffestb_else2_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + ffestb_local_.else_stmt.expr = expr; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffesta_tokens[1] = ffelex_token_use (ft); + ffelex_set_names (TRUE); + return (ffelexHandler) ffestb_else3_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ELSE IF", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_else3_ -- "ELSE" "IF" OPEN_PAREN expr CLOSE_PAREN + + return ffestb_else3_; // to lexer + + Make sure the next token is "THEN". */ + +static ffelexHandler +ffestb_else3_ (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + ffelex_set_names (FALSE); + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_confirmed (); + if (ffestr_first (t) == FFESTR_firstTHEN) + return (ffelexHandler) ffestb_else4_; + break; + + case FFELEX_typeNAMES: + ffesta_confirmed (); + if (ffestr_first (t) != FFESTR_firstTHEN) + break; + if (ffelex_token_length (t) == FFESTR_firstlTHEN) + return (ffelexHandler) ffestb_else4_; + p = ffelex_token_text (t) + (i = FFESTR_firstlTHEN); + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffesta_tokens[2] = ffelex_token_name_from_names (t, i, 0); + return (ffelexHandler) ffestb_else5_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ELSE IF", t); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "ELSE IF", t, i, NULL); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_else4_ -- "ELSE" "IF" OPEN_PAREN expr CLOSE_PAREN "THEN" + + return ffestb_else4_; // to lexer + + Handle a NAME or EOS/SEMICOLON, then go to state _5_. */ + +static ffelexHandler +ffestb_else4_ (ffelexToken t) +{ + ffelex_set_names (FALSE); + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_tokens[2] = NULL; + return (ffelexHandler) ffestb_else5_ (t); + + case FFELEX_typeNAME: + ffesta_tokens[2] = ffelex_token_use (t); + return (ffelexHandler) ffestb_else5_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ELSE IF", t); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_else5_ -- "ELSE" "IF" OPEN_PAREN expr CLOSE_PAREN "THEN" + + return ffestb_else5_; // to lexer + + Make sure the next token is EOS or SEMICOLON; implement R804. */ + +static ffelexHandler +ffestb_else5_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + ffestc_R804 (ffestb_local_.else_stmt.expr, ffesta_tokens[1], + ffesta_tokens[2]); + ffelex_token_kill (ffesta_tokens[1]); + if (ffesta_tokens[2] != NULL) + ffelex_token_kill (ffesta_tokens[2]); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ELSE IF", t); + ffelex_token_kill (ffesta_tokens[1]); + if (ffesta_tokens[2] != NULL) + ffelex_token_kill (ffesta_tokens[2]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_end -- Parse the END statement + + return ffestb_end; // to lexer + + Make sure the statement has a valid form for the END statement. If it + does, implement the statement. */ + +ffelexHandler +ffestb_end (ffelexToken t) +{ + ffeTokenLength i; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstEND) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_tokens[1] = NULL; + ffestb_args.endxyz.second = FFESTR_secondNone; + return (ffelexHandler) ffestb_end3_ (t); + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + break; + } + + ffesta_confirmed (); + ffestb_args.endxyz.second = ffesta_second_kw; + switch (ffesta_second_kw) + { + case FFESTR_secondFILE: + ffestb_args.beru.badname = "ENDFILE"; + return (ffelexHandler) ffestb_beru; + + case FFESTR_secondBLOCK: + return (ffelexHandler) ffestb_end1_; + +#if FFESTR_F90 + case FFESTR_secondINTERFACE: +#endif +#if FFESTR_VXT + case FFESTR_secondMAP: + case FFESTR_secondSTRUCTURE: + case FFESTR_secondUNION: +#endif +#if FFESTR_F90 + case FFESTR_secondWHERE: + ffesta_tokens[1] = NULL; + return (ffelexHandler) ffestb_end3_; +#endif + + case FFESTR_secondNone: + goto bad_1; /* :::::::::::::::::::: */ + + default: + return (ffelexHandler) ffestb_end2_; + } + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstEND) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + } + ffesta_confirmed (); + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlEND) + { + i = FFESTR_firstlEND; + goto bad_i; /* :::::::::::::::::::: */ + } + ffesta_tokens[1] = NULL; + ffestb_args.endxyz.second = FFESTR_secondNone; + return (ffelexHandler) ffestb_end3_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "END", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "END", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "END", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_endxyz -- Parse an ENDxyz statement + + return ffestb_endxyz; // to lexer + + Expects len and second to be set in ffestb_args.endxyz to the length + of the ENDxyz keyword involved and the corresponding ffestrSecond value. */ + +ffelexHandler +ffestb_endxyz (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + ffesta_tokens[1] = NULL; + return (ffelexHandler) ffestb_end3_ (t); + + case FFELEX_typeNAME: + ffesta_confirmed (); + switch (ffestb_args.endxyz.second) + { +#if FFESTR_F90 + case FFESTR_secondINTERFACE: +#endif +#if FFESTR_VXT + case FFESTR_secondMAP: + case FFESTR_secondSTRUCTURE: + case FFESTR_secondUNION: +#endif +#if FFESTR_F90 + case FFESTR_secondWHERE: + goto bad_1; /* :::::::::::::::::::: */ +#endif + + case FFESTR_secondBLOCK: + if (ffesta_second_kw != FFESTR_secondDATA) + goto bad_1; /* :::::::::::::::::::: */ + return (ffelexHandler) ffestb_end2_; + + default: + return (ffelexHandler) ffestb_end2_ (t); + } + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + case FFELEX_typeNAMES: + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + } + ffesta_confirmed (); + if (ffestb_args.endxyz.second == FFESTR_secondBLOCK) + { + i = FFESTR_firstlEND; + goto bad_i; /* :::::::::::::::::::: */ + } + if (ffelex_token_length (ffesta_tokens[0]) != ffestb_args.endxyz.len) + { + p = ffelex_token_text (ffesta_tokens[0]) + + (i = ffestb_args.endxyz.len); + switch (ffestb_args.endxyz.second) + { +#if FFESTR_F90 + case FFESTR_secondINTERFACE: +#endif +#if FFESTR_VXT + case FFESTR_secondMAP: + case FFESTR_secondSTRUCTURE: + case FFESTR_secondUNION: +#endif +#if FFESTR_F90 + case FFESTR_secondWHERE: + goto bad_i; /* :::::::::::::::::::: */ +#endif + + default: + break; + } + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffesta_tokens[1] + = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + return (ffelexHandler) ffestb_end3_ (t); + } + ffesta_tokens[1] = NULL; + return (ffelexHandler) ffestb_end3_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "END", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "END", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "END", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_end1_ -- "END" "BLOCK" + + return ffestb_end1_; // to lexer + + Make sure the next token is "DATA". */ + +static ffelexHandler +ffestb_end1_ (ffelexToken t) +{ + if ((ffelex_token_type (t) == FFELEX_typeNAME) + && (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DATA", + "data", "Data") + == 0)) + { + return (ffelexHandler) ffestb_end2_; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "END", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_end2_ -- "END" + + return ffestb_end2_; // to lexer + + Make sure the next token is a NAME or EOS. */ + +static ffelexHandler +ffestb_end2_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_end3_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_tokens[1] = NULL; + return (ffelexHandler) ffestb_end3_ (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "END", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + } +} + +/* ffestb_end3_ -- "END" (NAME) + + return ffestb_end3_; // to lexer + + Make sure the next token is an EOS, then implement the statement. */ + +static ffelexHandler +ffestb_end3_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "END", t); + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (ffestb_args.endxyz.second == FFESTR_secondNone) + { + if (!ffesta_is_inhibited ()) + ffestc_end (); + return (ffelexHandler) ffesta_zero (t); + } + break; + } + + switch (ffestb_args.endxyz.second) + { +#if FFESTR_F90 + case FFESTR_secondTYPE: + if (!ffesta_is_inhibited ()) + ffestc_R425 (ffesta_tokens[1]); + break; +#endif + +#if FFESTR_F90 + case FFESTR_secondWHERE: + if (!ffesta_is_inhibited ()) + ffestc_R745 (); + break; +#endif + + case FFESTR_secondIF: + if (!ffesta_is_inhibited ()) + ffestc_R806 (ffesta_tokens[1]); + break; + + case FFESTR_secondSELECT: + if (!ffesta_is_inhibited ()) + ffestc_R811 (ffesta_tokens[1]); + break; + + case FFESTR_secondDO: + if (!ffesta_is_inhibited ()) + ffestc_R825 (ffesta_tokens[1]); + break; + + case FFESTR_secondPROGRAM: + if (!ffesta_is_inhibited ()) + ffestc_R1103 (ffesta_tokens[1]); + break; + +#if FFESTR_F90 + case FFESTR_secondMODULE: + if (!ffesta_is_inhibited ()) + ffestc_R1106 (ffesta_tokens[1]); + break; +#endif + case FFESTR_secondBLOCK: + case FFESTR_secondBLOCKDATA: + if (!ffesta_is_inhibited ()) + ffestc_R1112 (ffesta_tokens[1]); + break; + +#if FFESTR_F90 + case FFESTR_secondINTERFACE: + if (!ffesta_is_inhibited ()) + ffestc_R1203 (); + break; +#endif + + case FFESTR_secondFUNCTION: + if (!ffesta_is_inhibited ()) + ffestc_R1221 (ffesta_tokens[1]); + break; + + case FFESTR_secondSUBROUTINE: + if (!ffesta_is_inhibited ()) + ffestc_R1225 (ffesta_tokens[1]); + break; + +#if FFESTR_VXT + case FFESTR_secondSTRUCTURE: + if (!ffesta_is_inhibited ()) + ffestc_V004 (); + break; +#endif + +#if FFESTR_VXT + case FFESTR_secondUNION: + if (!ffesta_is_inhibited ()) + ffestc_V010 (); + break; +#endif + +#if FFESTR_VXT + case FFESTR_secondMAP: + if (!ffesta_is_inhibited ()) + ffestc_V013 (); + break; +#endif + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "END", ffesta_tokens[0]); + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + } + + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); +} + +/* ffestb_goto -- Parse the GOTO statement + + return ffestb_goto; // to lexer + + Make sure the statement has a valid form for the GOTO statement. If it + does, implement the statement. */ + +ffelexHandler +ffestb_goto (ffelexToken t) +{ + ffeTokenLength i; + char *p; + ffelexHandler next; + ffelexToken nt; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + switch (ffesta_first_kw) + { + case FFESTR_firstGO: + if ((ffelex_token_type (t) != FFELEX_typeNAME) + || (ffesta_second_kw != FFESTR_secondTO)) + goto bad_1; /* :::::::::::::::::::: */ + ffesta_confirmed (); + return (ffelexHandler) ffestb_goto1_; + + case FFESTR_firstGOTO: + return (ffelexHandler) ffestb_goto1_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstGOTO) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + case FFELEX_typePERCENT: /* Since GOTO I%J is apparently valid + in '90. */ + case FFELEX_typeCOMMA: + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + break; + } + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlGOTO) + { + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlGOTO); + if (isdigit (*p)) + { + nt = ffelex_token_number_from_names (ffesta_tokens[0], i); + p += ffelex_token_length (nt); + i += ffelex_token_length (nt); + if (*p != '\0') + { + ffelex_token_kill (nt); + goto bad_i; /* :::::::::::::::::::: */ + } + } + else if (ffesrc_is_name_init (*p)) + { + nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + } + else + goto bad_i; /* :::::::::::::::::::: */ + next = (ffelexHandler) ffestb_goto1_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + } + return (ffelexHandler) ffestb_goto1_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "GO TO", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "GO TO", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "GO TO", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_goto1_ -- "GOTO" or "GO" "TO" + + return ffestb_goto1_; // to lexer + + Make sure the statement has a valid form for the GOTO statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_goto1_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + if (ffelex_token_type (ffesta_tokens[0]) == FFELEX_typeNAME) + ffesta_confirmed (); + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_goto2_; + + case FFELEX_typeOPEN_PAREN: + ffesta_tokens[1] = ffelex_token_use (t); + ffestb_subrargs_.label_list.labels = ffestt_tokenlist_create (); + ffestb_subrargs_.label_list.handler = (ffelexHandler) ffestb_goto3_; + return (ffelexHandler) ffestb_subr_label_list_; + + case FFELEX_typeNAME: + if (ffelex_token_type (ffesta_tokens[0]) == FFELEX_typeNAME) + ffesta_confirmed (); + return (ffelexHandler) (*((ffelexHandler) + ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextAGOTO, + (ffeexprCallback) ffestb_goto4_))) + (t); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + break; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "GO TO", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_goto2_ -- "GO/TO" NUMBER + + return ffestb_goto2_; // to lexer + + Make sure the statement has a valid form for the GOTO statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_goto2_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R836 (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "GO TO", t); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_goto3_ -- "GO/TO" OPEN_PAREN label-list CLOSE_PAREN + + return ffestb_goto3_; // to lexer + + Make sure the statement has a valid form for the GOTO statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_goto3_ (ffelexToken t) +{ + if (!ffestb_subrargs_.label_list.ok) + goto bad; /* :::::::::::::::::::: */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffesta_confirmed (); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, FFEEXPR_contextCGOTO, + (ffeexprCallback) ffestb_goto5_); + + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + + default: + ffesta_confirmed (); + /* Fall through. */ + case FFELEX_typeOPEN_PAREN: /* Could still be assignment!! */ + return (ffelexHandler) (*((ffelexHandler) + ffeexpr_rhs (ffesta_output_pool, FFEEXPR_contextCGOTO, + (ffeexprCallback) ffestb_goto5_))) + (t); + } + +bad: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "computed-GOTO", t); + ffelex_token_kill (ffesta_tokens[1]); + ffestt_tokenlist_kill (ffestb_subrargs_.label_list.labels); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_goto4_ -- "GO/TO" expr + + (ffestb_goto4_) // to expression handler + + Make sure the statement has a valid form for the GOTO statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_goto4_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (expr == NULL) + break; + ffesta_tokens[1] = ffelex_token_use (ft); + ffestb_local_.go_to.expr = expr; + return (ffelexHandler) ffestb_goto6_; + + case FFELEX_typeOPEN_PAREN: + if (expr == NULL) + break; + ffesta_tokens[1] = ffelex_token_use (ft); + ffestb_local_.go_to.expr = expr; + return (ffelexHandler) ffestb_goto6_ (t); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + ffestc_R839 (expr, ft, NULL); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "assigned-GOTO", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_goto5_ -- "GO/TO" OPEN_PAREN label-list CLOSE_PAREN (COMMA) expr + + (ffestb_goto5_) // to expression handler + + Make sure the statement has a valid form for the GOTO statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_goto5_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (expr == NULL) + break; + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R837 (ffestb_subrargs_.label_list.labels, expr, ft); + ffelex_token_kill (ffesta_tokens[1]); + ffestt_tokenlist_kill (ffestb_subrargs_.label_list.labels); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "computed-GOTO", t); + ffelex_token_kill (ffesta_tokens[1]); + ffestt_tokenlist_kill (ffestb_subrargs_.label_list.labels); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_goto6_ -- "GO/TO" expr (COMMA) + + return ffestb_goto6_; // to lexer + + Make sure the statement has a valid form for the GOTO statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_goto6_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + ffesta_tokens[2] = ffelex_token_use (t); + ffestb_subrargs_.label_list.labels = ffestt_tokenlist_create (); + ffestb_subrargs_.label_list.handler = (ffelexHandler) ffestb_goto7_; + return (ffelexHandler) ffestb_subr_label_list_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "assigned-GOTO", t); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_goto7_ -- "GO/TO" expr (COMMA) OPEN_PAREN label-list CLOSE_PAREN + + return ffestb_goto7_; // to lexer + + Make sure the statement has a valid form for the GOTO statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_goto7_ (ffelexToken t) +{ + if (!ffestb_subrargs_.label_list.ok) + goto bad; /* :::::::::::::::::::: */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R839 (ffestb_local_.go_to.expr, ffesta_tokens[1], + ffestb_subrargs_.label_list.labels); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffestt_tokenlist_kill (ffestb_subrargs_.label_list.labels); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "assigned-GOTO", t); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffestt_tokenlist_kill (ffestb_subrargs_.label_list.labels); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_halt -- Parse the STOP/PAUSE statement + + return ffestb_halt; // to lexer + + Make sure the statement has a valid form for the STOP/PAUSE statement. If + it does, implement the statement. */ + +ffelexHandler +ffestb_halt (ffelexToken t) +{ + ffelexHandler next; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeNAME: + case FFELEX_typeNUMBER: + case FFELEX_typeAPOSTROPHE: + case FFELEX_typeQUOTE: + ffesta_confirmed (); + break; + } + + return (ffelexHandler) (*((ffelexHandler) + ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextSTOP, + (ffeexprCallback) ffestb_halt1_))) + (t); + + case FFELEX_typeNAMES: + switch (ffelex_token_type (t)) + { + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeNAME: + case FFELEX_typeNUMBER: + case FFELEX_typeAPOSTROPHE: + case FFELEX_typeQUOTE: + ffesta_confirmed (); + break; + } + next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextSTOP, + (ffeexprCallback) ffestb_halt1_); + next = (ffelexHandler) ffelex_splice_tokens (next, ffesta_tokens[0], + ffestb_args.halt.len); + if (next == NULL) + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + return (ffelexHandler) (*next) (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, + (ffesta_first_kw == FFESTR_firstSTOP) + ? "STOP" : "PAUSE", + ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, + (ffesta_first_kw == FFESTR_firstSTOP) + ? "STOP" : "PAUSE", + t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_halt1_ -- "STOP/PAUSE" expr + + (ffestb_halt1_) // to expression handler + + Make sure the next token is an EOS or SEMICOLON. */ + +static ffelexHandler +ffestb_halt1_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + if (ffesta_first_kw == FFESTR_firstSTOP) + ffestc_R842 (expr, ft); + else + ffestc_R843 (expr, ft); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, + (ffesta_first_kw == FFESTR_firstSTOP) + ? "STOP" : "PAUSE", + t); + break; + } + + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_if -- Parse an IF statement + + return ffestb_if; // to lexer + + Make sure the statement has a valid form for an IF statement. + If it does, implement the statement. */ + +ffelexHandler +ffestb_if (ffelexToken t) +{ + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstIF) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstIF) + goto bad_0; /* :::::::::::::::::::: */ + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlIF) + goto bad_0; /* :::::::::::::::::::: */ + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, FFEEXPR_contextIF, + (ffeexprCallback) ffestb_if1_); + +bad_0: /* :::::::::::::::::::: */ + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IF", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IF", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_if1_ -- "IF" OPEN_PAREN expr + + (ffestb_if1_) // to expression handler + + Make sure the next token is CLOSE_PAREN. */ + +static ffelexHandler +ffestb_if1_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + ffestb_local_.if_stmt.expr = expr; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffesta_tokens[1] = ffelex_token_use (ft); + ffelex_set_names (TRUE); + return (ffelexHandler) ffestb_if2_; + + default: + break; + } + + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IF", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_if2_ -- "IF" OPEN_PAREN expr CLOSE_PAREN + + return ffestb_if2_; // to lexer + + Make sure the next token is NAME. */ + +static ffelexHandler +ffestb_if2_ (ffelexToken t) +{ + ffelex_set_names (FALSE); + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + case FFELEX_typeNAMES: + ffesta_confirmed (); + ffesta_tokens[2] = ffelex_token_use (t); + return (ffelexHandler) ffestb_if3_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + if ((ffesta_construct_name == NULL) + || (ffelex_token_type (t) != FFELEX_typeNUMBER)) + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IF", t); + else + ffesta_ffebad_2st (FFEBAD_INVALID_STMT_FORM, "CONSTRUCT", + ffesta_construct_name, t); + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_if3_ -- "IF" OPEN_PAREN expr CLOSE_PAREN NAME + + return ffestb_if3_; // to lexer + + If the next token is EOS or SEMICOLON and the preceding NAME was "THEN", + implement R803. Else, implement R807 and send the preceding NAME followed + by the current token. */ + +static ffelexHandler +ffestb_if3_ (ffelexToken t) +{ + ffelexHandler next; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (ffestr_first (ffesta_tokens[2]) == FFESTR_firstTHEN) + { + if (!ffesta_is_inhibited ()) + ffestc_R803 (ffesta_construct_name, ffestb_local_.if_stmt.expr, + ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + return (ffelexHandler) ffesta_zero (t); + } + break; + + default: + break; + } + + if (ffesta_construct_name != NULL) + { + if (!ffesta_is_inhibited ()) + ffesta_ffebad_2st (FFEBAD_INVALID_STMT_FORM, "CONSTRUCT", + ffesta_construct_name, ffesta_tokens[2]); + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + } + + if (!ffesta_is_inhibited ()) + ffestc_R807 (ffestb_local_.if_stmt.expr, ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + { + ffelexToken my_2 = ffesta_tokens[2]; + + next = (ffelexHandler) ffesta_two (my_2, t); + ffelex_token_kill (my_2); + } + return (ffelexHandler) next; +} + +/* ffestb_where -- Parse a WHERE statement + + return ffestb_where; // to lexer + + Make sure the statement has a valid form for a WHERE statement. + If it does, implement the statement. */ + +#if FFESTR_F90 +ffelexHandler +ffestb_where (ffelexToken t) +{ + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstWHERE) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstWHERE) + goto bad_0; /* :::::::::::::::::::: */ + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlWHERE) + goto bad_0; /* :::::::::::::::::::: */ + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, FFEEXPR_contextWHERE, + (ffeexprCallback) ffestb_where1_); + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WHERE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WHERE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +#endif +/* ffestb_where1_ -- "WHERE" OPEN_PAREN expr + + (ffestb_where1_) // to expression handler + + Make sure the next token is CLOSE_PAREN. */ + +#if FFESTR_F90 +static ffelexHandler +ffestb_where1_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + ffestb_local_.if_stmt.expr = expr; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffesta_tokens[1] = ffelex_token_use (ft); + ffelex_set_names (TRUE); + return (ffelexHandler) ffestb_where2_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WHERE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_where2_ -- "WHERE" OPEN_PAREN expr CLOSE_PAREN + + return ffestb_where2_; // to lexer + + Make sure the next token is NAME. */ + +#if FFESTR_F90 +static ffelexHandler +ffestb_where2_ (ffelexToken t) +{ + ffelex_set_names (FALSE); + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + case FFELEX_typeNAMES: + ffesta_confirmed (); + ffesta_tokens[2] = ffelex_token_use (t); + return (ffelexHandler) ffestb_where3_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R742 (ffestb_local_.if_stmt.expr, ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WHERE", t); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_where3_ -- "WHERE" OPEN_PAREN expr CLOSE_PAREN NAME + + return ffestb_where3_; // to lexer + + Implement R742. */ + +#if FFESTR_F90 +static ffelexHandler +ffestb_where3_ (ffelexToken t) +{ + ffelexHandler next; + ffelexToken my_2 = ffesta_tokens[2]; + + if (!ffesta_is_inhibited ()) + ffestc_R740 (ffestb_local_.if_stmt.expr, ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + next = (ffelexHandler) ffesta_two (my_2, t); + ffelex_token_kill (my_2); + return (ffelexHandler) next; +} + +#endif +/* ffestb_let -- Parse an assignment statement + + return ffestb_let; // to lexer + + Make sure the statement has a valid form for an assignment statement. If + it does, implement the statement. */ + +ffelexHandler +ffestb_let (ffelexToken t) +{ + ffelexHandler next; + bool vxtparam; /* TRUE if it might really be a VXT PARAMETER + stmt. */ + char *p; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + vxtparam = FALSE; + break; + + case FFELEX_typeNAMES: + vxtparam = TRUE; + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + case FFELEX_typePERCENT: + case FFELEX_typePOINTS: + ffestb_local_.let.vxtparam = FALSE; + break; + + case FFELEX_typeEQUALS: + if (!vxtparam || (ffesta_first_kw != FFESTR_firstPARAMETER)) + { + ffestb_local_.let.vxtparam = FALSE; + break; + } + p = ffelex_token_text (ffesta_tokens[0]) + FFESTR_firstlPARAMETER; + ffestb_local_.let.vxtparam = ffesrc_is_name_init (*p); + break; + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + next = (ffelexHandler) (*((ffelexHandler) + ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextLET, + (ffeexprCallback) ffestb_let1_))) + (ffesta_tokens[0]); + return (ffelexHandler) (*next) (t); + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "assignment", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "assignment", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_let1_ -- expr + + (ffestb_let1_) // to expression handler + + Make sure the next token is EQUALS or POINTS. */ + +static ffelexHandler +ffestb_let1_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) +{ + ffestb_local_.let.dest = expr; + + switch (ffelex_token_type (t)) + { +#if FFESTR_F90 + case FFELEX_typePOINTS: +#endif + case FFELEX_typeEQUALS: + if (expr == NULL) + break; + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextLET, (ffeexprCallback) ffestb_let2_); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "assignment", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_let2_ -- expr EQUALS/POINTS expr + + (ffestb_end2_) // to expression handler + + Make sure the next token is EOS or SEMICOLON; implement the statement. */ + +static ffelexHandler +ffestb_let2_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (expr == NULL) + break; + if (ffestb_local_.let.vxtparam && !ffestc_is_let_not_V027 ()) + break; + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) +#if FFESTR_F90 + if (ffelex_token_type (ffesta_tokens[1]) == FFELEX_typeEQUALS) +#endif + ffestc_let (ffestb_local_.let.dest, expr, ft); +#if FFESTR_F90 + else + ffestc_R738 (ffestb_local_.let.dest, expr, ft); +#endif + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, + (ffelex_token_type (ffesta_tokens[1]) == FFELEX_typeEQUALS) + ? "assignment" : "pointer-assignment", + t); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_type -- Parse the TYPE statement + + return ffestb_type; // to lexer + + Make sure the statement has a valid form for the TYPE statement. If + it does, implement the statement. */ + +#if FFESTR_F90 +ffelexHandler +ffestb_type (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstTYPE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeCOMMA: + ffesta_confirmed (); + return (ffelexHandler) ffestb_type1_; + + case FFELEX_typeNAME: /* No confirm here, because ambig w/V020 VXT + TYPE. */ + ffesta_tokens[1] = NULL; + ffesta_tokens[2] = ffelex_token_use (t); + return (ffelexHandler) ffestb_type4_; + } + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstTYPE) + goto bad_0; /* :::::::::::::::::::: */ + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlTYPE); + switch (ffelex_token_type (t)) + { + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeCOMMA: + if (*p != '\0') + goto bad_i; /* :::::::::::::::::::: */ + ffesta_confirmed (); + ffelex_set_names (TRUE); + return (ffelexHandler) ffestb_type1_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + } + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffesta_tokens[1] = NULL; + ffesta_tokens[2] + = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + return (ffelexHandler) ffestb_type4_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "TYPE", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_type1_ -- "TYPE" COMMA + + return ffestb_type1_; // to lexer + + Make sure the next token is a NAME. */ + +static ffelexHandler +ffestb_type1_ (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + ffelex_set_names (FALSE); + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + ffestb_local_.type.kw = ffestr_other (t); + switch (ffestb_local_.varlist.kw) + { + case FFESTR_otherPUBLIC: + case FFESTR_otherPRIVATE: + return (ffelexHandler) ffestb_type2_; + + default: + ffelex_token_kill (ffesta_tokens[1]); + break; + } + break; + + case FFELEX_typeNAMES: + ffesta_tokens[1] = ffelex_token_use (t); + ffestb_local_.type.kw = ffestr_other (t); + switch (ffestb_local_.varlist.kw) + { + case FFESTR_otherPUBLIC: + p = ffelex_token_text (t) + (i = FFESTR_otherlPUBLIC); + if (*p == '\0') + return (ffelexHandler) ffestb_type2_; + if (!ffesrc_is_name_init (*p)) + goto bad_i1; /* :::::::::::::::::::: */ + ffesta_tokens[2] = ffelex_token_name_from_names (t, i, 0); + return (ffelexHandler) ffestb_type4_; + + case FFESTR_otherPRIVATE: + p = ffelex_token_text (t) + (i = FFESTR_otherlPRIVATE); + if (*p == '\0') + return (ffelexHandler) ffestb_type2_; + if (!ffesrc_is_name_init (*p)) + goto bad_i1; /* :::::::::::::::::::: */ + ffesta_tokens[2] = ffelex_token_name_from_names (t, i, 0); + return (ffelexHandler) ffestb_type4_; + + default: + ffelex_token_kill (ffesta_tokens[1]); + break; + } + break; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_i1: /* :::::::::::::::::::: */ + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "TYPE", t, i, NULL); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_type2_ -- "TYPE" COMMA NAME + + return ffestb_type2_; // to lexer + + Handle COLONCOLON or NAME. */ + +static ffelexHandler +ffestb_type2_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOLONCOLON: + return (ffelexHandler) ffestb_type3_; + + case FFELEX_typeNAME: + return (ffelexHandler) ffestb_type3_ (t); + + default: + break; + } + + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_type3_ -- "TYPE" [COMMA NAME [COLONCOLON]] + + return ffestb_type3_; // to lexer + + Make sure the next token is a NAME. */ + +static ffelexHandler +ffestb_type3_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[2] = ffelex_token_use (t); + return (ffelexHandler) ffestb_type4_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE", t); + break; + } + + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_type4_ -- "TYPE" [COMMA NAME [COLONCOLON]] NAME + + return ffestb_type4_; // to lexer + + Make sure the next token is an EOS or SEMICOLON. */ + +static ffelexHandler +ffestb_type4_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R424 (ffesta_tokens[1], ffestb_local_.type.kw, + ffesta_tokens[2]); + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE", t); + break; + } + + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_varlist -- Parse EXTERNAL/INTENT/INTRINSIC/OPTIONAL/PUBLIC/PRIVATE + statement + + return ffestb_varlist; // to lexer + + Make sure the statement has a valid form. If it + does, implement the statement. */ + +ffelexHandler +ffestb_varlist (ffelexToken t) +{ + ffeTokenLength i; + char *p; + ffelexToken nt; + ffelexHandler next; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + switch (ffesta_first_kw) + { +#if FFESTR_F90 + case FFESTR_firstPUBLIC: + if (!ffesta_is_inhibited ()) + ffestc_R521A (); + return (ffelexHandler) ffesta_zero (t); + + case FFESTR_firstPRIVATE: + if (!ffesta_is_inhibited ()) + ffestc_private (); /* Either R523A or R521B. */ + return (ffelexHandler) ffesta_zero (t); +#endif + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + case FFELEX_typeCOMMA: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); + switch (ffesta_first_kw) + { +#if FFESTR_F90 + case FFESTR_firstOPTIONAL: + if (!ffesta_is_inhibited ()) + ffestc_R520_start (); + break; + + case FFESTR_firstPUBLIC: + if (!ffesta_is_inhibited ()) + ffestc_R521Astart (); + break; + + case FFESTR_firstPRIVATE: + if (!ffesta_is_inhibited ()) + ffestc_R521Bstart (); + break; +#endif + + default: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + } + return (ffelexHandler) ffestb_varlist5_; + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + switch (ffesta_first_kw) + { +#if FFESTR_F90 + case FFESTR_firstINTENT: + return (ffelexHandler) ffestb_varlist1_; +#endif + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + case FFELEX_typeNAME: + ffesta_confirmed (); + switch (ffesta_first_kw) + { + case FFESTR_firstEXTERNAL: + if (!ffesta_is_inhibited ()) + ffestc_R1207_start (); + break; + +#if FFESTR_F90 + case FFESTR_firstINTENT: + goto bad_1; /* :::::::::::::::::::: */ +#endif + + case FFESTR_firstINTRINSIC: + if (!ffesta_is_inhibited ()) + ffestc_R1208_start (); + break; + +#if FFESTR_F90 + case FFESTR_firstOPTIONAL: + if (!ffesta_is_inhibited ()) + ffestc_R520_start (); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstPUBLIC: + if (!ffesta_is_inhibited ()) + ffestc_R521Astart (); + break; + + case FFESTR_firstPRIVATE: + if (!ffesta_is_inhibited ()) + ffestc_R521Bstart (); + break; +#endif + + default: + break; + } + return (ffelexHandler) ffestb_varlist5_ (t); + } + + case FFELEX_typeNAMES: + p = ffelex_token_text (ffesta_tokens[0]) + (i = ffestb_args.varlist.len); + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + switch (ffesta_first_kw) + { +#if FFESTR_F90 + case FFESTR_firstINTENT: + goto bad_1; /* :::::::::::::::::::: */ +#endif + + default: + break; + } + if (*p != '\0') + break; + switch (ffesta_first_kw) + { +#if FFESTR_F90 + case FFESTR_firstPUBLIC: + if (!ffesta_is_inhibited ()) + ffestc_R521A (); + return (ffelexHandler) ffesta_zero (t); + + case FFESTR_firstPRIVATE: + if (!ffesta_is_inhibited ()) + ffestc_private (); /* Either R423A or R521B. */ + return (ffelexHandler) ffesta_zero (t); +#endif + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + case FFELEX_typeCOMMA: + ffesta_confirmed (); /* Error, but clearly intended. */ + switch (ffesta_first_kw) + { +#if FFESTR_F90 + case FFESTR_firstINTENT: + goto bad_1; /* :::::::::::::::::::: */ +#endif + + default: + break; + } + if (*p != '\0') + break; + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); + switch (ffesta_first_kw) + { +#if FFESTR_F90 + case FFESTR_firstOPTIONAL: + if (!ffesta_is_inhibited ()) + ffestc_R520_start (); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstPUBLIC: + if (!ffesta_is_inhibited ()) + ffestc_R521Astart (); + break; + + case FFESTR_firstPRIVATE: + if (!ffesta_is_inhibited ()) + ffestc_R521Bstart (); + break; +#endif + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + return (ffelexHandler) ffestb_varlist5_; + + case FFELEX_typeOPEN_PAREN: + switch (ffesta_first_kw) + { +#if FFESTR_F90 + case FFESTR_firstINTENT: + if (*p != '\0') + goto bad_1; /* :::::::::::::::::::: */ + return (ffelexHandler) ffestb_varlist1_; +#endif + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + case FFELEX_typeNAME: + ffesta_confirmed (); + switch (ffesta_first_kw) + { + case FFESTR_firstEXTERNAL: + if (!ffesta_is_inhibited ()) + ffestc_R1207_start (); + break; + +#if FFESTR_F90 + case FFESTR_firstINTENT: + goto bad_1; /* :::::::::::::::::::: */ +#endif + + case FFESTR_firstINTRINSIC: + if (!ffesta_is_inhibited ()) + ffestc_R1208_start (); + break; + +#if FFESTR_F90 + case FFESTR_firstOPTIONAL: + if (!ffesta_is_inhibited ()) + ffestc_R520_start (); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstPUBLIC: + if (!ffesta_is_inhibited ()) + ffestc_R521Astart (); + break; + + case FFESTR_firstPRIVATE: + if (!ffesta_is_inhibited ()) + ffestc_R521Bstart (); + break; +#endif + + default: + break; + } + return (ffelexHandler) ffestb_varlist5_ (t); + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + /* Here, we have at least one char after the first keyword and t is + COMMA or EOS/SEMICOLON. Also we know that this form is valid for + only the statements reaching here (specifically, INTENT won't reach + here). */ + + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + if (!ffesta_is_inhibited ()) + { + switch (ffesta_first_kw) + { + case FFESTR_firstEXTERNAL: + ffestc_R1207_start (); + break; + + case FFESTR_firstINTRINSIC: + ffestc_R1208_start (); + break; + +#if FFESTR_F90 + case FFESTR_firstOPTIONAL: + ffestc_R520_start (); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstPUBLIC: + ffestc_R521Astart (); + break; + + case FFESTR_firstPRIVATE: + ffestc_R521Bstart (); + break; +#endif + + default: + assert (FALSE); + } + } + next = (ffelexHandler) ffestb_varlist5_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_varlist1_ -- "INTENT" OPEN_PAREN + + return ffestb_varlist1_; // to lexer + + Handle NAME. */ + +#if FFESTR_F90 +static ffelexHandler +ffestb_varlist1_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + ffestb_local_.varlist.kw = ffestr_other (t); + switch (ffestb_local_.varlist.kw) + { + case FFESTR_otherIN: + return (ffelexHandler) ffestb_varlist2_; + + case FFESTR_otherINOUT: + return (ffelexHandler) ffestb_varlist3_; + + case FFESTR_otherOUT: + return (ffelexHandler) ffestb_varlist3_; + + default: + ffelex_token_kill (ffesta_tokens[1]); + break; + } + break; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_varlist2_ -- "INTENT" OPEN_PAREN "IN" + + return ffestb_varlist2_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_varlist2_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + switch (ffestr_other (t)) + { + case FFESTR_otherOUT: + ffestb_local_.varlist.kw = FFESTR_otherINOUT; + return (ffelexHandler) ffestb_varlist3_; + + default: + break; + } + break; + + case FFELEX_typeCLOSE_PAREN: + return (ffelexHandler) ffestb_varlist4_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_varlist3_ -- "INTENT" OPEN_PAREN NAME ["OUT"] + + return ffestb_varlist3_; // to lexer + + Handle CLOSE_PAREN. */ + +static ffelexHandler +ffestb_varlist3_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + return (ffelexHandler) ffestb_varlist4_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_varlist4_ -- "INTENT" OPEN_PAREN NAME ["OUT"] CLOSE_PAREN + + return ffestb_varlist4_; // to lexer + + Handle COLONCOLON or NAME. */ + +static ffelexHandler +ffestb_varlist4_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R519_start (ffesta_tokens[1], ffestb_local_.varlist.kw); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_varlist5_; + + case FFELEX_typeNAME: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R519_start (ffesta_tokens[1], ffestb_local_.varlist.kw); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_varlist5_ (t); + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_varlist5_ -- Handles the list of variable names + + return ffestb_varlist5_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_varlist5_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_varlist6_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, t); + break; + } + + if (!ffesta_is_inhibited ()) + { + switch (ffesta_first_kw) + { + case FFESTR_firstEXTERNAL: + ffestc_R1207_finish (); + break; + +#if FFESTR_F90 + case FFESTR_firstINTENT: + ffestc_R519_finish (); + break; +#endif + + case FFESTR_firstINTRINSIC: + ffestc_R1208_finish (); + break; + +#if FFESTR_F90 + case FFESTR_firstOPTIONAL: + ffestc_R520_finish (); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstPUBLIC: + ffestc_R521Afinish (); + break; + + case FFESTR_firstPRIVATE: + ffestc_R521Bfinish (); + break; +#endif + + default: + assert (FALSE); + } + } + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_varlist6_ -- (whatever) NAME + + return ffestb_varlist6_; // to lexer + + Handle COMMA or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_varlist6_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (!ffesta_is_inhibited ()) + { + switch (ffesta_first_kw) + { + case FFESTR_firstEXTERNAL: + ffestc_R1207_item (ffesta_tokens[1]); + break; + +#if FFESTR_F90 + case FFESTR_firstINTENT: + ffestc_R519_item (ffesta_tokens[1]); + break; +#endif + + case FFESTR_firstINTRINSIC: + ffestc_R1208_item (ffesta_tokens[1]); + break; + +#if FFESTR_F90 + case FFESTR_firstOPTIONAL: + ffestc_R520_item (ffesta_tokens[1]); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstPUBLIC: + ffestc_R521Aitem (ffesta_tokens[1]); + break; + + case FFESTR_firstPRIVATE: + ffestc_R521Bitem (ffesta_tokens[1]); + break; +#endif + + default: + assert (FALSE); + } + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_varlist5_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + { + switch (ffesta_first_kw) + { + case FFESTR_firstEXTERNAL: + ffestc_R1207_item (ffesta_tokens[1]); + ffestc_R1207_finish (); + break; + +#if FFESTR_F90 + case FFESTR_firstINTENT: + ffestc_R519_item (ffesta_tokens[1]); + ffestc_R519_finish (); + break; +#endif + + case FFESTR_firstINTRINSIC: + ffestc_R1208_item (ffesta_tokens[1]); + ffestc_R1208_finish (); + break; + +#if FFESTR_F90 + case FFESTR_firstOPTIONAL: + ffestc_R520_item (ffesta_tokens[1]); + ffestc_R520_finish (); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstPUBLIC: + ffestc_R521Aitem (ffesta_tokens[1]); + ffestc_R521Afinish (); + break; + + case FFESTR_firstPRIVATE: + ffestc_R521Bitem (ffesta_tokens[1]); + ffestc_R521Bfinish (); + break; +#endif + + default: + assert (FALSE); + } + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.varlist.badname, t); + break; + } + + if (!ffesta_is_inhibited ()) + { + switch (ffesta_first_kw) + { + case FFESTR_firstEXTERNAL: + ffestc_R1207_finish (); + break; + +#if FFESTR_F90 + case FFESTR_firstINTENT: + ffestc_R519_finish (); + break; +#endif + + case FFESTR_firstINTRINSIC: + ffestc_R1208_finish (); + break; + +#if FFESTR_F90 + case FFESTR_firstOPTIONAL: + ffestc_R520_finish (); + break; +#endif + +#if FFESTR_F90 + case FFESTR_firstPUBLIC: + ffestc_R521Afinish (); + break; + + case FFESTR_firstPRIVATE: + ffestc_R521Bfinish (); + break; +#endif + + default: + assert (FALSE); + } + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R423B -- Parse the SEQUENCE statement + + return ffestb_R423B; // to lexer + + Make sure the statement has a valid form for the SEQUENCE statement. If + it does, implement the statement. */ + +#if FFESTR_F90 +ffelexHandler +ffestb_R423B (ffelexToken t) +{ + char *p; + ffeTokenLength i; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstSEQUENCE) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstSEQUENCE) + goto bad_0; /* :::::::::::::::::::: */ + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlSEQUENCE) + { + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlSEQUENCE); + goto bad_i; /* :::::::::::::::::::: */ + } + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R423B (); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SEQUENCE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid first token. */ + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SEQUENCE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "SEQUENCE", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_R522 -- Parse the SAVE statement + + return ffestb_R522; // to lexer + + Make sure the statement has a valid form for the SAVE statement. If it + does, implement the statement. */ + +ffelexHandler +ffestb_R522 (ffelexToken t) +{ + ffeTokenLength i; + char *p; + ffelexToken nt; + ffelexHandler next; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstSAVE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R522 (); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeNAME: + case FFELEX_typeSLASH: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R522start (); + return (ffelexHandler) ffestb_R5221_ (t); + + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R522start (); + return (ffelexHandler) ffestb_R5221_; + } + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstSAVE) + goto bad_0; /* :::::::::::::::::::: */ + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlSAVE); + switch (ffelex_token_type (t)) + { + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeCOMMA: + ffesta_confirmed (); + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (*p != '\0') + break; + if (!ffesta_is_inhibited ()) + ffestc_R522 (); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeSLASH: + ffesta_confirmed (); + if (*p != '\0') + goto bad_i; /* :::::::::::::::::::: */ + if (!ffesta_is_inhibited ()) + ffestc_R522start (); + return (ffelexHandler) ffestb_R5221_ (t); + + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); + if (*p != '\0') + goto bad_i; /* :::::::::::::::::::: */ + if (!ffesta_is_inhibited ()) + ffestc_R522start (); + return (ffelexHandler) ffestb_R5221_; + } + + /* Here, we have at least one char after "SAVE" and t is COMMA or + EOS/SEMICOLON. */ + + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + if (!ffesta_is_inhibited ()) + ffestc_R522start (); + next = (ffelexHandler) ffestb_R5221_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SAVE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SAVE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "SAVE", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5221_ -- "SAVE" [COLONCOLON] + + return ffestb_R5221_; // to lexer + + Handle NAME or SLASH. */ + +static ffelexHandler +ffestb_R5221_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffestb_local_.R522.is_cblock = FALSE; + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R5224_; + + case FFELEX_typeSLASH: + ffestb_local_.R522.is_cblock = TRUE; + return (ffelexHandler) ffestb_R5222_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SAVE", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R522finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5222_ -- "SAVE" [COLONCOLON] SLASH + + return ffestb_R5222_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_R5222_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R5223_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SAVE", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R522finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5223_ -- "SAVE" [COLONCOLON] SLASH NAME + + return ffestb_R5223_; // to lexer + + Handle SLASH. */ + +static ffelexHandler +ffestb_R5223_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeSLASH: + return (ffelexHandler) ffestb_R5224_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SAVE", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R522finish (); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5224_ -- "SAVE" [COLONCOLON] R523 + + return ffestb_R5224_; // to lexer + + Handle COMMA or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_R5224_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (!ffesta_is_inhibited ()) + { + if (ffestb_local_.R522.is_cblock) + ffestc_R522item_cblock (ffesta_tokens[1]); + else + ffestc_R522item_object (ffesta_tokens[1]); + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_R5221_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + { + if (ffestb_local_.R522.is_cblock) + ffestc_R522item_cblock (ffesta_tokens[1]); + else + ffestc_R522item_object (ffesta_tokens[1]); + ffestc_R522finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SAVE", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R522finish (); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R528 -- Parse the DATA statement + + return ffestb_R528; // to lexer + + Make sure the statement has a valid form for the DATA statement. If it + does, implement the statement. */ + +ffelexHandler +ffestb_R528 (ffelexToken t) +{ + char *p; + ffeTokenLength i; + ffelexToken nt; + ffelexHandler next; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstDATA) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeSLASH: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + ffesta_confirmed (); + break; + + case FFELEX_typeOPEN_PAREN: + break; + } + ffestb_local_.data.started = FALSE; + return (ffelexHandler) (*((ffelexHandler) + ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextDATA, + (ffeexprCallback) ffestb_R5281_))) + (t); + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstDATA) + goto bad_0; /* :::::::::::::::::::: */ + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlDATA); + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + if (*p == '\0') + { + ffestb_local_.data.started = FALSE; + return (ffelexHandler) (*((ffelexHandler) + ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextDATA, + (ffeexprCallback) + ffestb_R5281_))) + (t); + } + break; + + case FFELEX_typeCOMMA: + case FFELEX_typeSLASH: + ffesta_confirmed (); + break; + } + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffestb_local_.data.started = FALSE; + nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + next = (ffelexHandler) (*((ffelexHandler) + ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextDATA, + (ffeexprCallback) ffestb_R5281_))) + (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DATA", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DATA", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "DATA", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5281_ -- "DATA" expr-list + + (ffestb_R5281_) // to expression handler + + Handle COMMA or SLASH. */ + +static ffelexHandler +ffestb_R5281_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + { + if (!ffestb_local_.data.started) + { + ffestc_R528_start (); + ffestb_local_.data.started = TRUE; + } + ffestc_R528_item_object (expr, ft); + } + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextDATA, + (ffeexprCallback) ffestb_R5281_); + + case FFELEX_typeSLASH: + ffesta_confirmed (); + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + { + if (!ffestb_local_.data.started) + { + ffestc_R528_start (); + ffestb_local_.data.started = TRUE; + } + ffestc_R528_item_object (expr, ft); + ffestc_R528_item_startvals (); + } + return (ffelexHandler) ffeexpr_rhs + (ffesta_output_pool, FFEEXPR_contextDATA, + (ffeexprCallback) ffestb_R5282_); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DATA", t); + break; + } + + if (ffestb_local_.data.started && !ffesta_is_inhibited ()) + ffestc_R528_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5282_ -- "DATA" expr-list SLASH expr-list + + (ffestb_R5282_) // to expression handler + + Handle ASTERISK, COMMA, or SLASH. */ + +static ffelexHandler +ffestb_R5282_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + ffestc_R528_item_value (NULL, NULL, expr, ft); + return (ffelexHandler) ffeexpr_rhs + (ffesta_output_pool, FFEEXPR_contextDATA, + (ffeexprCallback) ffestb_R5282_); + + case FFELEX_typeASTERISK: + if (expr == NULL) + break; + ffestb_local_.data.expr = expr; + ffesta_tokens[1] = ffelex_token_use (ft); + return (ffelexHandler) ffeexpr_rhs + (ffesta_output_pool, FFEEXPR_contextDATA, + (ffeexprCallback) ffestb_R5283_); + + case FFELEX_typeSLASH: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + { + ffestc_R528_item_value (NULL, NULL, expr, ft); + ffestc_R528_item_endvals (t); + } + return (ffelexHandler) ffestb_R5284_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DATA", t); + break; + } + + if (!ffesta_is_inhibited ()) + { + ffestc_R528_item_endvals (t); + ffestc_R528_finish (); + } + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5283_ -- "DATA" expr-list SLASH expr ASTERISK expr + + (ffestb_R5283_) // to expression handler + + Handle COMMA or SLASH. */ + +static ffelexHandler +ffestb_R5283_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + ffestc_R528_item_value (ffestb_local_.data.expr, ffesta_tokens[1], + expr, ft); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffeexpr_rhs + (ffesta_output_pool, FFEEXPR_contextDATA, + (ffeexprCallback) ffestb_R5282_); + + case FFELEX_typeSLASH: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + { + ffestc_R528_item_value (ffestb_local_.data.expr, ffesta_tokens[1], + expr, ft); + ffestc_R528_item_endvals (t); + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_R5284_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DATA", t); + break; + } + + if (!ffesta_is_inhibited ()) + { + ffestc_R528_item_endvals (t); + ffestc_R528_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5284_ -- "DATA" expr-list SLASH expr-list SLASH + + return ffestb_R5284_; // to lexer + + Handle [COMMA] NAME or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_R5284_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextDATA, + (ffeexprCallback) ffestb_R5281_); + + case FFELEX_typeNAME: + return (ffelexHandler) (*((ffelexHandler) + ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextDATA, + (ffeexprCallback) ffestb_R5281_))) + (t); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + ffestc_R528_finish (); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DATA", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R528_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R537 -- Parse a PARAMETER statement + + return ffestb_R537; // to lexer + + Make sure the statement has a valid form for an PARAMETER statement. + If it does, implement the statement. */ + +ffelexHandler +ffestb_R537 (ffelexToken t) +{ + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstPARAMETER) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstPARAMETER) + goto bad_0; /* :::::::::::::::::::: */ + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlPARAMETER) + goto bad_0; /* :::::::::::::::::::: */ + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + ffestb_local_.parameter.started = FALSE; + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextPARAMETER, + (ffeexprCallback) ffestb_R5371_); + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_R5371_ -- "PARAMETER" OPEN_PAREN expr + + (ffestb_R5371_) // to expression handler + + Make sure the next token is EQUALS. */ + +static ffelexHandler +ffestb_R5371_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + ffestb_local_.parameter.expr = expr; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + ffesta_confirmed (); + if (expr == NULL) + break; + ffesta_tokens[1] = ffelex_token_use (ft); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextPARAMETER, (ffeexprCallback) ffestb_R5372_); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", t); + if (ffestb_local_.parameter.started) + ffestc_R537_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5372_ -- "PARAMETER" OPEN_PAREN expr EQUALS expr + + (ffestb_R5372_) // to expression handler + + Make sure the next token is COMMA or CLOSE_PAREN. */ + +static ffelexHandler +ffestb_R5372_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + { + if (!ffestb_local_.parameter.started) + { + ffestc_R537_start (); + ffestb_local_.parameter.started = TRUE; + } + ffestc_R537_item (ffestb_local_.parameter.expr, ffesta_tokens[1], + expr, ft); + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextPARAMETER, + (ffeexprCallback) ffestb_R5371_); + + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + { + if (!ffestb_local_.parameter.started) + { + ffestc_R537_start (); + ffestb_local_.parameter.started = TRUE; + } + ffestc_R537_item (ffestb_local_.parameter.expr, ffesta_tokens[1], + expr, ft); + ffestc_R537_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_R5373_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", t); + if (ffestb_local_.parameter.started) + ffestc_R537_finish (); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5373_ -- "PARAMETER" OPEN_PAREN expr EQUALS expr CLOSE_PAREN + + return ffestb_R5373_; // to lexer + + Make sure the next token is EOS or SEMICOLON, or generate an error. All + cleanup has already been done, by the way. */ + +static ffelexHandler +ffestb_R5373_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R542 -- Parse the NAMELIST statement + + return ffestb_R542; // to lexer + + Make sure the statement has a valid form for the NAMELIST statement. If it + does, implement the statement. */ + +ffelexHandler +ffestb_R542 (ffelexToken t) +{ + char *p; + ffeTokenLength i; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstNAMELIST) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstNAMELIST) + goto bad_0; /* :::::::::::::::::::: */ + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlNAMELIST); + if (*p != '\0') + goto bad_i; /* :::::::::::::::::::: */ + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeSLASH: + break; + } + + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R542_start (); + return (ffelexHandler) ffestb_R5421_; + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "NAMELIST", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5421_ -- "NAMELIST" SLASH + + return ffestb_R5421_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_R5421_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + if (!ffesta_is_inhibited ()) + ffestc_R542_item_nlist (t); + return (ffelexHandler) ffestb_R5422_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R542_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5422_ -- "NAMELIST" SLASH NAME + + return ffestb_R5422_; // to lexer + + Handle SLASH. */ + +static ffelexHandler +ffestb_R5422_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeSLASH: + return (ffelexHandler) ffestb_R5423_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R542_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5423_ -- "NAMELIST" SLASH NAME SLASH + + return ffestb_R5423_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_R5423_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + if (!ffesta_is_inhibited ()) + ffestc_R542_item_nitem (t); + return (ffelexHandler) ffestb_R5424_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R542_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5424_ -- "NAMELIST" SLASH NAME SLASH NAME + + return ffestb_R5424_; // to lexer + + Handle COMMA, EOS/SEMICOLON, or SLASH. */ + +static ffelexHandler +ffestb_R5424_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_R5425_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + ffestc_R542_finish (); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeSLASH: + return (ffelexHandler) ffestb_R5421_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R542_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5425_ -- "NAMELIST" SLASH NAME SLASH NAME COMMA + + return ffestb_R5425_; // to lexer + + Handle NAME or SLASH. */ + +static ffelexHandler +ffestb_R5425_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + if (!ffesta_is_inhibited ()) + ffestc_R542_item_nitem (t); + return (ffelexHandler) ffestb_R5424_; + + case FFELEX_typeSLASH: + return (ffelexHandler) ffestb_R5421_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NAMELIST", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R542_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R544 -- Parse an EQUIVALENCE statement + + return ffestb_R544; // to lexer + + Make sure the statement has a valid form for an EQUIVALENCE statement. + If it does, implement the statement. */ + +ffelexHandler +ffestb_R544 (ffelexToken t) +{ + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstEQUIVALENCE) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstEQUIVALENCE) + goto bad_0; /* :::::::::::::::::::: */ + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlEQUIVALENCE) + goto bad_0; /* :::::::::::::::::::: */ + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + ffestb_local_.equivalence.started = FALSE; + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextEQUIVALENCE, + (ffeexprCallback) ffestb_R5441_); + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EQUIVALENCE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EQUIVALENCE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_R5441_ -- "EQUIVALENCE" OPEN_PAREN expr + + (ffestb_R5441_) // to expression handler + + Make sure the next token is COMMA. */ + +static ffelexHandler +ffestb_R5441_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + ffestb_local_.equivalence.exprs = ffestt_exprlist_create (); + ffestt_exprlist_append (ffestb_local_.equivalence.exprs, expr, + ffelex_token_use (ft)); + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextEQUIVALENCE, + (ffeexprCallback) ffestb_R5442_); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EQUIVALENCE", t); + if (ffestb_local_.equivalence.started) + ffestc_R544_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5442_ -- "EQUIVALENCE" OPEN_PAREN expr COMMA expr + + (ffestb_R5442_) // to expression handler + + Make sure the next token is COMMA or CLOSE_PAREN. For COMMA, we just + append the expression to our list and continue; for CLOSE_PAREN, we + append the expression and move to _3_. */ + +static ffelexHandler +ffestb_R5442_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + ffestt_exprlist_append (ffestb_local_.equivalence.exprs, expr, + ffelex_token_use (ft)); + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextEQUIVALENCE, + (ffeexprCallback) ffestb_R5442_); + + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestt_exprlist_append (ffestb_local_.equivalence.exprs, expr, + ffelex_token_use (ft)); + return (ffelexHandler) ffestb_R5443_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EQUIVALENCE", t); + if (ffestb_local_.equivalence.started) + ffestc_R544_finish (); + ffestt_exprlist_kill (ffestb_local_.equivalence.exprs); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5443_ -- "EQUIVALENCE" OPEN_PAREN expr COMMA expr CLOSE_PAREN + + return ffestb_R5443_; // to lexer + + Make sure the next token is COMMA or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_R5443_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + if (!ffestb_local_.equivalence.started) + { + ffestc_R544_start (); + ffestb_local_.equivalence.started = TRUE; + } + ffestc_R544_item (ffestb_local_.equivalence.exprs); + } + ffestt_exprlist_kill (ffestb_local_.equivalence.exprs); + return (ffelexHandler) ffestb_R5444_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + if (!ffestb_local_.equivalence.started) + { + ffestc_R544_start (); + ffestb_local_.equivalence.started = TRUE; + } + ffestc_R544_item (ffestb_local_.equivalence.exprs); + ffestc_R544_finish (); + } + ffestt_exprlist_kill (ffestb_local_.equivalence.exprs); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EQUIVALENCE", t); + if (ffestb_local_.equivalence.started) + ffestc_R544_finish (); + ffestt_exprlist_kill (ffestb_local_.equivalence.exprs); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5444_ -- "EQUIVALENCE" OPEN_PAREN expr COMMA expr CLOSE_PAREN COMMA + + return ffestb_R5444_; // to lexer + + Make sure the next token is OPEN_PAREN, or generate an error. */ + +static ffelexHandler +ffestb_R5444_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextEQUIVALENCE, + (ffeexprCallback) ffestb_R5441_); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EQUIVALENCE", t); + if (ffestb_local_.equivalence.started) + ffestc_R544_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R834 -- Parse the CYCLE statement + + return ffestb_R834; // to lexer + + Make sure the statement has a valid form for the CYCLE statement. If + it does, implement the statement. */ + +ffelexHandler +ffestb_R834 (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstCYCLE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + ffesta_confirmed (); + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R8341_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + ffesta_tokens[1] = NULL; + return (ffelexHandler) ffestb_R8341_ (t); + } + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstCYCLE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + } + ffesta_confirmed (); + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCYCLE); + if (*p == '\0') + { + ffesta_tokens[1] = NULL; + } + else + { + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffesta_tokens[1] + = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + } + return (ffelexHandler) ffestb_R8341_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CYCLE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CYCLE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "CYCLE", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R8341_ -- "CYCLE" [NAME] + + return ffestb_R8341_; // to lexer + + Make sure the next token is an EOS or SEMICOLON. */ + +static ffelexHandler +ffestb_R8341_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R834 (ffesta_tokens[1]); + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CYCLE", t); + break; + } + + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R835 -- Parse the EXIT statement + + return ffestb_R835; // to lexer + + Make sure the statement has a valid form for the EXIT statement. If + it does, implement the statement. */ + +ffelexHandler +ffestb_R835 (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstEXIT) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + ffesta_confirmed (); + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R8351_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + ffesta_tokens[1] = NULL; + return (ffelexHandler) ffestb_R8351_ (t); + } + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstEXIT) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + } + ffesta_confirmed (); + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlEXIT); + if (*p == '\0') + { + ffesta_tokens[1] = NULL; + } + else + { + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffesta_tokens[1] + = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + } + return (ffelexHandler) ffestb_R8351_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EXIT", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EXIT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "EXIT", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R8351_ -- "EXIT" [NAME] + + return ffestb_R8351_; // to lexer + + Make sure the next token is an EOS or SEMICOLON. */ + +static ffelexHandler +ffestb_R8351_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R835 (ffesta_tokens[1]); + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "EXIT", t); + break; + } + + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R838 -- Parse the ASSIGN statement + + return ffestb_R838; // to lexer + + Make sure the statement has a valid form for the ASSIGN statement. If it + does, implement the statement. */ + +ffelexHandler +ffestb_R838 (ffelexToken t) +{ + char *p; + ffeTokenLength i; + ffelexHandler next; + ffelexToken et; /* First token in target. */ + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstASSIGN) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNUMBER: + break; + } + ffesta_tokens[1] = ffelex_token_use (t); + ffesta_confirmed (); + return (ffelexHandler) ffestb_R8381_; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstASSIGN) + goto bad_0; /* :::::::::::::::::::: */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + /* Fall through. */ + case FFELEX_typePERCENT: + case FFELEX_typeOPEN_PAREN: + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlASSIGN); + if (!isdigit (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffesta_tokens[1] + = ffelex_token_number_from_names (ffesta_tokens[0], i); + p += ffelex_token_length (ffesta_tokens[1]); /* Skip to "TO". */ + i += ffelex_token_length (ffesta_tokens[1]); + if (!ffesrc_char_match_init (*p, 'T', 't') /* "TO". */ + || (++i, !ffesrc_char_match_noninit (*++p, 'O', 'o'))) + { + bad_i_1: /* :::::::::::::::::::: */ + ffelex_token_kill (ffesta_tokens[1]); + goto bad_i; /* :::::::::::::::::::: */ + } + ++p, ++i; + if (!ffesrc_is_name_init (*p)) + goto bad_i_1; /* :::::::::::::::::::: */ + et = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + next = (ffelexHandler) + (*((ffelexHandler) + ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextASSIGN, + (ffeexprCallback) + ffestb_R8383_))) + (et); + ffelex_token_kill (et); + return (ffelexHandler) (*next) (t); + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ASSIGN", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid first token. */ + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ASSIGN", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "ASSIGN", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R8381_ -- "ASSIGN" NUMBER + + return ffestb_R8381_; // to lexer + + Make sure the next token is "TO". */ + +static ffelexHandler +ffestb_R8381_ (ffelexToken t) +{ + if ((ffelex_token_type (t) == FFELEX_typeNAME) + && (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "TO", "to", + "To") == 0)) + { + return (ffelexHandler) ffestb_R8382_; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ASSIGN", t); + if (ffelex_token_type (t) == FFELEX_typeNAME) + return (ffelexHandler) ffestb_R8382_ (t); /* Maybe user forgot "TO". */ + + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R8382_ -- "ASSIGN" NUMBER ("TO") + + return ffestb_R8382_; // to lexer + + Make sure the next token is a name, then pass it along to the expression + evaluator as an LHS expression. The callback function is _3_. */ + +static ffelexHandler +ffestb_R8382_ (ffelexToken t) +{ + if (ffelex_token_type (t) == FFELEX_typeNAME) + { + return (ffelexHandler) + (*((ffelexHandler) + ffeexpr_lhs (ffesta_output_pool, FFEEXPR_contextASSIGN, + (ffeexprCallback) ffestb_R8383_))) + (t); + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ASSIGN", t); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R8383_ -- "ASSIGN" NUMBER ("TO") expression + + (ffestb_R8383_) // to expression handler + + Make sure the next token is an EOS or SEMICOLON. */ + +static ffelexHandler +ffestb_R8383_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + ffestc_R838 (ffesta_tokens[1], expr, ft); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ASSIGN", t); + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R840 -- Parse an arithmetic-IF statement + + return ffestb_R840; // to lexer + + Make sure the statement has a valid form for an arithmetic-IF statement. + If it does, implement the statement. */ + +ffelexHandler +ffestb_R840 (ffelexToken t) +{ + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlIF) + goto bad_0; /* :::::::::::::::::::: */ + if (ffesta_first_kw != FFESTR_firstIF) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstIF) + goto bad_0; /* :::::::::::::::::::: */ + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + break; + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, FFEEXPR_contextARITHIF, + (ffeexprCallback) ffestb_R8401_); + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_R8401_ -- "IF" OPEN_PAREN expr + + (ffestb_R8401_) // to expression handler + + Make sure the next token is CLOSE_PAREN. */ + +static ffelexHandler +ffestb_R8401_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + ffestb_local_.if_stmt.expr = expr; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffesta_tokens[1] = ffelex_token_use (ft); + ffelex_set_names (TRUE); /* In case it's a logical IF instead. */ + return (ffelexHandler) ffestb_R8402_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R8402_ -- "IF" OPEN_PAREN expr CLOSE_PAREN + + return ffestb_R8402_; // to lexer + + Make sure the next token is NUMBER. */ + +static ffelexHandler +ffestb_R8402_ (ffelexToken t) +{ + ffelex_set_names (FALSE); + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + ffesta_confirmed (); + ffesta_tokens[2] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R8403_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R8403_ -- "IF" OPEN_PAREN expr CLOSE_PAREN NUMBER + + return ffestb_R8403_; // to lexer + + Make sure the next token is COMMA. */ + +static ffelexHandler +ffestb_R8403_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_R8404_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R8404_ -- "IF" OPEN_PAREN expr CLOSE_PAREN NUMBER COMMA + + return ffestb_R8404_; // to lexer + + Make sure the next token is NUMBER. */ + +static ffelexHandler +ffestb_R8404_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + ffesta_tokens[3] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R8405_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R8405_ -- "IF" OPEN_PAREN expr CLOSE_PAREN NUMBER COMMA NUMBER + + return ffestb_R8405_; // to lexer + + Make sure the next token is COMMA. */ + +static ffelexHandler +ffestb_R8405_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_R8406_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffelex_token_kill (ffesta_tokens[3]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R8406_ -- "IF" OPEN_PAREN expr CLOSE_PAREN NUMBER COMMA NUMBER COMMA + + return ffestb_R8406_; // to lexer + + Make sure the next token is NUMBER. */ + +static ffelexHandler +ffestb_R8406_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + ffesta_tokens[4] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R8407_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffelex_token_kill (ffesta_tokens[3]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R8407_ -- "IF" OPEN_PAREN expr CLOSE_PAREN NUMBER COMMA NUMBER COMMA + NUMBER + + return ffestb_R8407_; // to lexer + + Make sure the next token is EOS or SEMICOLON. */ + +static ffelexHandler +ffestb_R8407_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + ffestc_R840 (ffestb_local_.if_stmt.expr, ffesta_tokens[1], + ffesta_tokens[2], ffesta_tokens[3], ffesta_tokens[4]); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffelex_token_kill (ffesta_tokens[3]); + ffelex_token_kill (ffesta_tokens[4]); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "arithmetic-IF", t); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffelex_token_kill (ffesta_tokens[3]); + ffelex_token_kill (ffesta_tokens[4]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R841 -- Parse the CONTINUE statement + + return ffestb_R841; // to lexer + + Make sure the statement has a valid form for the CONTINUE statement. If + it does, implement the statement. */ + +ffelexHandler +ffestb_R841 (ffelexToken t) +{ + char *p; + ffeTokenLength i; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstCONTINUE) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstCONTINUE) + goto bad_0; /* :::::::::::::::::::: */ + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlCONTINUE) + { + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCONTINUE); + goto bad_i; /* :::::::::::::::::::: */ + } + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R841 (); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CONTINUE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid first token. */ + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CONTINUE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "CONTINUE", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R1102 -- Parse the PROGRAM statement + + return ffestb_R1102; // to lexer + + Make sure the statement has a valid form for the PROGRAM statement. If it + does, implement the statement. */ + +ffelexHandler +ffestb_R1102 (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstPROGRAM) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + break; + } + + ffesta_confirmed (); + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R11021_; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstPROGRAM) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + } + ffesta_confirmed (); + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlPROGRAM); + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffesta_tokens[1] + = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + return (ffelexHandler) ffestb_R11021_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PROGRAM", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PROGRAM", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "PROGRAM", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R11021_ -- "PROGRAM" NAME + + return ffestb_R11021_; // to lexer + + Make sure the next token is an EOS or SEMICOLON. */ + +static ffelexHandler +ffestb_R11021_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R1102 (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PROGRAM", t); + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_block -- Parse the BLOCK DATA statement + + return ffestb_block; // to lexer + + Make sure the statement has a valid form for the BLOCK DATA statement. If + it does, implement the statement. */ + +ffelexHandler +ffestb_block (ffelexToken t) +{ + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstBLOCK) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + if (ffesta_second_kw != FFESTR_secondDATA) + goto bad_1; /* :::::::::::::::::::: */ + break; + } + + ffesta_confirmed (); + return (ffelexHandler) ffestb_R1111_1_; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_blockdata -- Parse the BLOCKDATA statement + + return ffestb_blockdata; // to lexer + + Make sure the statement has a valid form for the BLOCKDATA statement. If + it does, implement the statement. */ + +ffelexHandler +ffestb_blockdata (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstBLOCKDATA) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + ffesta_confirmed (); + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R1111_2_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + ffesta_tokens[1] = NULL; + return (ffelexHandler) ffestb_R1111_2_ (t); + } + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstBLOCKDATA) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + } + ffesta_confirmed (); + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlBLOCKDATA); + if (*p == '\0') + { + ffesta_tokens[1] = NULL; + } + else + { + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffesta_tokens[1] + = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + } + return (ffelexHandler) ffestb_R1111_2_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R1111_1_ -- "BLOCK" "DATA" + + return ffestb_R1111_1_; // to lexer + + Make sure the next token is a NAME, EOS, or SEMICOLON token. */ + +static ffelexHandler +ffestb_R1111_1_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R1111_2_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_tokens[1] = NULL; + return (ffelexHandler) ffestb_R1111_2_ (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", t); + break; + } + + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R1111_2_ -- "BLOCK/DATA" NAME + + return ffestb_R1111_2_; // to lexer + + Make sure the next token is an EOS or SEMICOLON. */ + +static ffelexHandler +ffestb_R1111_2_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R1111 (ffesta_tokens[1]); + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "BLOCK DATA", t); + break; + } + + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R1212 -- Parse the CALL statement + + return ffestb_R1212; // to lexer + + Make sure the statement has a valid form for the CALL statement. If it + does, implement the statement. */ + +ffelexHandler +ffestb_R1212 (ffelexToken t) +{ + ffeTokenLength i; + char *p; + ffelexHandler next; + ffelexToken nt; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstCALL) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + break; + } + ffesta_confirmed (); + return (ffelexHandler) + (*((ffelexHandler) + ffeexpr_lhs (ffesta_output_pool, FFEEXPR_contextSUBROUTINEREF, + (ffeexprCallback) ffestb_R12121_))) + (t); + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstCALL) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOLONCOLON: + case FFELEX_typeCOMMA: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + break; + } + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCALL); + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + next = (ffelexHandler) + (*((ffelexHandler) + ffeexpr_lhs (ffesta_output_pool, FFEEXPR_contextSUBROUTINEREF, + (ffeexprCallback) ffestb_R12121_))) + (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CALL", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CALL", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "CALL", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R12121_ -- "CALL" expr + + (ffestb_R12121_) // to expression handler + + Make sure the statement has a valid form for the CALL statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R12121_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + ffestc_R1212 (expr, ft); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CALL", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R1227 -- Parse the RETURN statement + + return ffestb_R1227; // to lexer + + Make sure the statement has a valid form for the RETURN statement. If it + does, implement the statement. */ + +ffelexHandler +ffestb_R1227 (ffelexToken t) +{ + ffelexHandler next; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstRETURN) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + case FFELEX_typeCOLON: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeNAME: + case FFELEX_typeNUMBER: + ffesta_confirmed (); + break; + + default: + break; + } + + return (ffelexHandler) (*((ffelexHandler) + ffeexpr_rhs (ffesta_output_pool, FFEEXPR_contextRETURN, + (ffeexprCallback) ffestb_R12271_))) + (t); + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstRETURN) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + case FFELEX_typeCOLON: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + break; + + default: + break; + } + next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextRETURN, (ffeexprCallback) ffestb_R12271_); + next = (ffelexHandler) ffelex_splice_tokens (next, ffesta_tokens[0], + FFESTR_firstlRETURN); + if (next == NULL) + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + return (ffelexHandler) (*next) (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RETURN", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RETURN", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_R12271_ -- "RETURN" expr + + (ffestb_R12271_) // to expression handler + + Make sure the next token is an EOS or SEMICOLON. */ + +static ffelexHandler +ffestb_R12271_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R1227 (expr, ft); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RETURN", t); + break; + } + + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R1228 -- Parse the CONTAINS statement + + return ffestb_R1228; // to lexer + + Make sure the statement has a valid form for the CONTAINS statement. If + it does, implement the statement. */ + +#if FFESTR_F90 +ffelexHandler +ffestb_R1228 (ffelexToken t) +{ + char *p; + ffeTokenLength i; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstCONTAINS) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstCONTAINS) + goto bad_0; /* :::::::::::::::::::: */ + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlCONTAINS) + { + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCONTAINS); + goto bad_i; /* :::::::::::::::::::: */ + } + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R1228 (); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CONTAINS", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid first token. */ + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CONTAINS", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "CONTAINS", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_V009 -- Parse the UNION statement + + return ffestb_V009; // to lexer + + Make sure the statement has a valid form for the UNION statement. If + it does, implement the statement. */ + +#if FFESTR_VXT +ffelexHandler +ffestb_V009 (ffelexToken t) +{ + char *p; + ffeTokenLength i; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstUNION) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstUNION) + goto bad_0; /* :::::::::::::::::::: */ + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlUNION) + { + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlUNION); + goto bad_i; /* :::::::::::::::::::: */ + } + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_V009 (); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "UNION", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid first token. */ + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "UNION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "UNION", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_construct -- Parse a construct name + + return ffestb_construct; // to lexer + + Make sure the statement can have a construct name (if-then-stmt, do-stmt, + select-case-stmt). */ + +ffelexHandler +ffestb_construct (ffelexToken t UNUSED) +{ + /* This handler gets invoked only when token 0 is NAME/NAMES and token 1 is + COLON. */ + + ffesta_confirmed (); + ffelex_set_names (TRUE); + return (ffelexHandler) ffestb_construct1_; +} + +/* ffestb_construct1_ -- NAME COLON + + return ffestb_construct1_; // to lexer + + Make sure we've got a NAME that is DO, DOWHILE, IF, SELECT, or SELECTCASE. */ + +static ffelexHandler +ffestb_construct1_ (ffelexToken t) +{ + ffelex_set_names (FALSE); + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_first_kw = ffestr_first (t); + switch (ffesta_first_kw) + { + case FFESTR_firstIF: + ffestb_local_.construct.next = (ffelexHandler) ffestb_if; + break; + + case FFESTR_firstDO: + ffestb_local_.construct.next = (ffelexHandler) ffestb_do; + break; + + case FFESTR_firstDOWHILE: + ffestb_local_.construct.next = (ffelexHandler) ffestb_dowhile; + break; + + case FFESTR_firstSELECT: + case FFESTR_firstSELECTCASE: + ffestb_local_.construct.next = (ffelexHandler) ffestb_R809; + break; + + default: + goto bad; /* :::::::::::::::::::: */ + } + ffesta_construct_name = ffesta_tokens[0]; + ffesta_tokens[0] = ffelex_token_use (t); + return (ffelexHandler) ffestb_construct2_; + + case FFELEX_typeNAMES: + ffesta_first_kw = ffestr_first (t); + switch (ffesta_first_kw) + { + case FFESTR_firstIF: + if (ffelex_token_length (t) != FFESTR_firstlIF) + goto bad; /* :::::::::::::::::::: */ + ffestb_local_.construct.next = (ffelexHandler) ffestb_if; + break; + + case FFESTR_firstDO: + ffestb_local_.construct.next = (ffelexHandler) ffestb_do; + break; + + case FFESTR_firstDOWHILE: + if (ffelex_token_length (t) != FFESTR_firstlDOWHILE) + goto bad; /* :::::::::::::::::::: */ + ffestb_local_.construct.next = (ffelexHandler) ffestb_dowhile; + break; + + case FFESTR_firstSELECTCASE: + if (ffelex_token_length (t) != FFESTR_firstlSELECTCASE) + goto bad; /* :::::::::::::::::::: */ + ffestb_local_.construct.next = (ffelexHandler) ffestb_R809; + break; + + default: + goto bad; /* :::::::::::::::::::: */ + } + ffesta_construct_name = ffesta_tokens[0]; + ffesta_tokens[0] = ffelex_token_use (t); + return (ffelexHandler) ffestb_construct2_; + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffesta_ffebad_2st (FFEBAD_INVALID_STMT_FORM, "CONSTRUCT", + ffesta_tokens[0], t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_construct2_ -- NAME COLON "DO/DOWHILE/IF/SELECT/SELECTCASE" + + return ffestb_construct2_; // to lexer + + This extra step is needed to set ffesta_second_kw if the second token + (here) is a NAME, so DO and SELECT can continue to expect it. */ + +static ffelexHandler +ffestb_construct2_ (ffelexToken t) +{ + if (ffelex_token_type (t) == FFELEX_typeNAME) + ffesta_second_kw = ffestr_second (t); + return (ffelexHandler) (*ffestb_local_.construct.next) (t); +} + +/* ffestb_heap -- Parse an ALLOCATE/DEALLOCATE statement + + return ffestb_heap; // to lexer + + Make sure the statement has a valid form for an ALLOCATE/DEALLOCATE + statement. If it does, implement the statement. */ + +#if FFESTR_F90 +ffelexHandler +ffestb_heap (ffelexToken t) +{ + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + break; + + case FFELEX_typeNAMES: + if (ffelex_token_length (ffesta_tokens[0]) != ffestb_args.heap.len) + goto bad_0; /* :::::::::::::::::::: */ + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + ffestb_local_.heap.exprs = ffestt_exprlist_create (); + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + ffestb_args.heap.ctx, + (ffeexprCallback) ffestb_heap1_); + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.heap.badname, ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.heap.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_heap1_ -- "ALLOCATE/DEALLOCATE" OPEN_PAREN expr + + (ffestb_heap1_) // to expression handler + + Make sure the next token is COMMA. */ + +static ffelexHandler +ffestb_heap1_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + ffestt_exprlist_append (ffestb_local_.heap.exprs, expr, + ffelex_token_use (t)); + return (ffelexHandler) ffestb_heap2_; + + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestt_exprlist_append (ffestb_local_.heap.exprs, expr, + ffelex_token_use (t)); + ffesta_tokens[1] = NULL; + ffestb_local_.heap.expr = NULL; + return (ffelexHandler) ffestb_heap5_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.heap.badname, t); + ffestt_exprlist_kill (ffestb_local_.heap.exprs); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_heap2_ -- "ALLOCATE/DEALLOCATE" OPEN_PAREN expr COMMA + + return ffestb_heap2_; // to lexer + + Make sure the next token is NAME. */ + +static ffelexHandler +ffestb_heap2_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_heap3_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.heap.badname, t); + ffestt_exprlist_kill (ffestb_local_.heap.exprs); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_heap3_ -- "ALLOCATE/DEALLOCATE" OPEN_PAREN expr COMMA NAME + + return ffestb_heap3_; // to lexer + + If token is EQUALS, make sure NAME was "STAT" and handle STAT variable; + else pass NAME and token to expression handler. */ + +static ffelexHandler +ffestb_heap3_ (ffelexToken t) +{ + ffelexHandler next; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + ffesta_confirmed (); + if (ffestr_other (ffesta_tokens[1]) != FFESTR_otherSTAT) + break; + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextHEAPSTAT, + (ffeexprCallback) ffestb_heap4_); + + default: + next = (ffelexHandler) + (*((ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + ffestb_args.heap.ctx, + (ffeexprCallback) ffestb_heap1_))) + (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) (*next) (t); + } + + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.heap.badname, t); + ffestt_exprlist_kill (ffestb_local_.heap.exprs); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_heap4_ -- "ALLOCATE/DEALLOCATE" OPEN_PAREN ... COMMA "STAT" EQUALS + expr + + (ffestb_heap4_) // to expression handler + + Make sure the next token is CLOSE_PAREN. */ + +static ffelexHandler +ffestb_heap4_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffesta_tokens[1] = ffelex_token_use (ft); + ffestb_local_.heap.expr = expr; + return (ffelexHandler) ffestb_heap5_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.heap.badname, t); + ffestt_exprlist_kill (ffestb_local_.heap.exprs); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_heap5_ -- "ALLOCATE/DEALLOCATE" OPEN_PAREN ... CLOSE_PAREN + + return ffestb_heap5_; // to lexer + + Make sure the next token is EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_heap5_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + if (ffesta_first_kw == FFESTR_firstALLOCATE) + ffestc_R620 (ffestb_local_.heap.exprs, ffestb_local_.heap.expr, + ffesta_tokens[1]); + else + ffestc_R625 (ffestb_local_.heap.exprs, ffestb_local_.heap.expr, + ffesta_tokens[1]); + ffestt_exprlist_kill (ffestb_local_.heap.exprs); + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.heap.badname, t); + ffestt_exprlist_kill (ffestb_local_.heap.exprs); + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_module -- Parse the MODULEPROCEDURE statement + + return ffestb_module; // to lexer + + Make sure the statement has a valid form for the MODULEPROCEDURE statement. + If it does, implement the statement. + + 31-May-90 JCB 1.1 + Confirm NAME==MODULE followed by standard four invalid tokens, so we + get decent message if somebody forgets that MODULE requires a name. */ + +#if FFESTR_F90 +ffelexHandler +ffestb_module (ffelexToken t) +{ + ffeTokenLength i; + char *p; + ffelexToken nt; + ffelexToken mt; /* Name in MODULE PROCEDUREname, i.e. + includes "PROCEDURE". */ + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstMODULE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + break; + + case FFELEX_typeCOLONCOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + goto bad_1m; /* :::::::::::::::::::: */ + + default: + goto bad_1m; /* :::::::::::::::::::: */ + } + + ffesta_confirmed (); + if (ffesta_second_kw != FFESTR_secondPROCEDURE) + { + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_module3_; + } + ffestb_local_.moduleprocedure.started = FALSE; + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_module1_; + + case FFELEX_typeNAMES: + p = ffelex_token_text (ffesta_tokens[0]) + + (i = FFESTR_firstlMODULEPROCEDURE); + if ((ffesta_first_kw == FFESTR_firstMODULE) + || ((ffesta_first_kw == FFESTR_firstMODULEPROCEDURE) + && !ffesrc_is_name_init (*p))) + { /* Definitely not "MODULE PROCEDURE name". */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1m; /* :::::::::::::::::::: */ + + default: + goto bad_1m; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + break; + } + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlMODULE); + if (!ffesrc_is_name_init (*p)) + goto bad_im; /* :::::::::::::::::::: */ + nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + if (!ffesta_is_inhibited ()) + ffestc_R1105 (nt); + ffelex_token_kill (nt); + return (ffelexHandler) ffesta_zero (t); + } + + /* Here we know that we're indeed looking at a MODULEPROCEDURE + statement rather than MODULE and that the character following + MODULEPROCEDURE in the NAMES token is a valid first character for a + NAME. This means that unless the second token is COMMA, we have an + ambiguous statement that can be read either as MODULE PROCEDURE name + or MODULE PROCEDUREname, the former being an R1205, the latter an + R1105. */ + + if (ffesta_first_kw != FFESTR_firstMODULEPROCEDURE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeCOMMA: /* Aha, clearly not MODULE PROCEDUREname. */ + ffesta_confirmed (); + ffestb_local_.moduleprocedure.started = FALSE; + ffesta_tokens[1] + = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + return (ffelexHandler) ffestb_module2_ (t); + + case FFELEX_typeEOS: /* MODULE PROCEDURE name or MODULE + PROCEDUREname. */ + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + break; + } + nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + mt = ffelex_token_name_from_names (ffesta_tokens[0], FFESTR_firstlMODULE, + 0); + if (!ffesta_is_inhibited ()) + ffestc_module (mt, nt); /* Implement ambiguous statement. */ + ffelex_token_kill (nt); + ffelex_token_kill (mt); + return (ffelexHandler) ffesta_zero (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "MODULE PROCEDURE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "MODULE PROCEDURE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_1m: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "MODULE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_im: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "MODULE", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_module1_ -- "MODULEPROCEDURE" or "MODULE" "PROCEDURE" + + return ffestb_module1_; // to lexer + + Make sure the statement has a valid form for the MODULEPROCEDURE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_module1_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + if (!ffestb_local_.moduleprocedure.started + && (ffelex_token_type (ffesta_tokens[0]) == FFELEX_typeNAME)) + { + ffesta_confirmed (); + ffelex_token_kill (ffesta_tokens[1]); + } + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_module2_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (ffestb_local_.moduleprocedure.started) + break; /* Error if we've already seen NAME COMMA. */ + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R1105 (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + break; + + default: + break; + } + + if (ffestb_local_.moduleprocedure.started && !ffesta_is_inhibited ()) + ffestc_R1205_finish (); + else if (!ffestb_local_.moduleprocedure.started) + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "MODULE PROCEDURE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_module2_ -- "MODULE/PROCEDURE" NAME + + return ffestb_module2_; // to lexer + + Make sure the statement has a valid form for the MODULEPROCEDURE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_module2_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffestb_local_.moduleprocedure.started) + { + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R1205_start (); + } + if (!ffesta_is_inhibited ()) + { + ffestc_R1205_item (ffesta_tokens[1]); + ffestc_R1205_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeCOMMA: + if (!ffestb_local_.moduleprocedure.started) + { + ffestb_local_.moduleprocedure.started = TRUE; + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R1205_start (); + } + if (!ffesta_is_inhibited ()) + ffestc_R1205_item (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_module1_; + + default: + break; + } + + if (ffestb_local_.moduleprocedure.started && !ffesta_is_inhibited ()) + ffestc_R1205_finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "MODULE PROCEDURE", t); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_module3_ -- "MODULE" NAME + + return ffestb_module3_; // to lexer + + Make sure the statement has a valid form for the MODULE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_module3_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + ffestc_R1105 (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "MODULE", t); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_R809 -- Parse the SELECTCASE statement + + return ffestb_R809; // to lexer + + Make sure the statement has a valid form for the SELECTCASE statement. + If it does, implement the statement. */ + +ffelexHandler +ffestb_R809 (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + switch (ffesta_first_kw) + { + case FFESTR_firstSELECT: + if ((ffelex_token_type (t) != FFELEX_typeNAME) + || (ffesta_second_kw != FFESTR_secondCASE)) + goto bad_1; /* :::::::::::::::::::: */ + ffesta_confirmed (); + return (ffelexHandler) ffestb_R8091_; + + case FFESTR_firstSELECTCASE: + return (ffelexHandler) ffestb_R8091_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstSELECTCASE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + break; + } + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlSELECTCASE); + if (*p != '\0') + goto bad_i; /* :::::::::::::::::::: */ + return (ffelexHandler) ffestb_R8091_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SELECT CASE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SELECT CASE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "SELECT CASE", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R8091_ -- "SELECTCASE" or "SELECT" "CASE" + + return ffestb_R8091_; // to lexer + + Make sure the statement has a valid form for the SELECTCASE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R8091_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextSELECTCASE, (ffeexprCallback) ffestb_R8092_); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + break; + + default: + break; + } + + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SELECT CASE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R8092_ -- "SELECT/CASE" OPEN_PAREN expr + + (ffestb_R8092_) // to expression handler + + Make sure the statement has a valid form for the SELECTCASE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R8092_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffesta_tokens[1] = ffelex_token_use (ft); + ffestb_local_.selectcase.expr = expr; + return (ffelexHandler) ffestb_R8093_; + + default: + break; + } + + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SELECT CASE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R8093_ -- "SELECT/CASE" OPEN_PAREN expr CLOSE_PAREN + + return ffestb_R8093_; // to lexer + + Make sure the statement has a valid form for the SELECTCASE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R8093_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R809 (ffesta_construct_name, ffestb_local_.selectcase.expr, + ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + return ffesta_zero (t); + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + break; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + if (ffesta_construct_name != NULL) + { + ffelex_token_kill (ffesta_construct_name); + ffesta_construct_name = NULL; + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "SELECT CASE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R810 -- Parse the CASE statement + + return ffestb_R810; // to lexer + + Make sure the statement has a valid form for the CASE statement. + If it does, implement the statement. */ + +ffelexHandler +ffestb_R810 (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstCASE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + ffesta_confirmed (); + if (ffesta_second_kw != FFESTR_secondDEFAULT) + goto bad_1; /* :::::::::::::::::::: */ + ffestb_local_.case_stmt.cases = NULL; + return (ffelexHandler) ffestb_R8101_; + + case FFELEX_typeOPEN_PAREN: + ffestb_local_.case_stmt.cases = ffestt_caselist_create (); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextCASE, (ffeexprCallback) ffestb_R8103_); + } + + case FFELEX_typeNAMES: + switch (ffesta_first_kw) + { + case FFESTR_firstCASEDEFAULT: + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + break; + } + ffestb_local_.case_stmt.cases = NULL; + p = ffelex_token_text (ffesta_tokens[0]) + + (i = FFESTR_firstlCASEDEFAULT); + if (*p == '\0') + return (ffelexHandler) ffestb_R8101_ (t); + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffesta_tokens[1] = ffelex_token_name_from_names (ffesta_tokens[0], i, + 0); + return (ffelexHandler) ffestb_R8102_ (t); + + case FFESTR_firstCASE: + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + break; + } + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCASE); + if (*p != '\0') + goto bad_i; /* :::::::::::::::::::: */ + ffestb_local_.case_stmt.cases = ffestt_caselist_create (); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextCASE, (ffeexprCallback) ffestb_R8103_); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CASE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CASE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "CASE", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R8101_ -- "CASE" case-selector + + return ffestb_R8101_; // to lexer + + Make sure the statement has a valid form for the CASE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R8101_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R8102_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_tokens[1] = NULL; + return (ffelexHandler) ffestb_R8102_ (t); + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + break; + + default: + break; + } + + if (ffestb_local_.case_stmt.cases != NULL) + ffestt_caselist_kill (ffestb_local_.case_stmt.cases); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CASE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R8102_ -- "CASE" case-selector [NAME] + + return ffestb_R8102_; // to lexer + + Make sure the statement has a valid form for the CASE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R8102_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R810 (ffestb_local_.case_stmt.cases, ffesta_tokens[1]); + if (ffestb_local_.case_stmt.cases != NULL) + ffestt_caselist_kill (ffestb_local_.case_stmt.cases); + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + break; + + default: + break; + } + + if (ffestb_local_.case_stmt.cases != NULL) + ffestt_caselist_kill (ffestb_local_.case_stmt.cases); + if (ffesta_tokens[1] != NULL) + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CASE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R8103_ -- "CASE" OPEN_PAREN expr + + (ffestb_R8103_) // to expression handler + + Make sure the statement has a valid form for the CASE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R8103_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + ffestt_caselist_append (ffestb_local_.case_stmt.cases, FALSE, expr, NULL, + ffelex_token_use (ft)); + return (ffelexHandler) ffestb_R8101_; + + case FFELEX_typeCOMMA: + ffestt_caselist_append (ffestb_local_.case_stmt.cases, FALSE, expr, NULL, + ffelex_token_use (ft)); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextCASE, (ffeexprCallback) ffestb_R8103_); + + case FFELEX_typeCOLON: + ffestt_caselist_append (ffestb_local_.case_stmt.cases, TRUE, expr, NULL, + ffelex_token_use (ft)); /* NULL second expr for + now, just plug in. */ + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextCASE, (ffeexprCallback) ffestb_R8104_); + + default: + break; + } + + ffestt_caselist_kill (ffestb_local_.case_stmt.cases); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CASE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R8104_ -- "CASE" OPEN_PAREN expr COLON expr + + (ffestb_R8104_) // to expression handler + + Make sure the statement has a valid form for the CASE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R8104_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + ffestb_local_.case_stmt.cases->previous->expr2 = expr; + return (ffelexHandler) ffestb_R8101_; + + case FFELEX_typeCOMMA: + ffestb_local_.case_stmt.cases->previous->expr2 = expr; + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextCASE, (ffeexprCallback) ffestb_R8103_); + + default: + break; + } + + ffestt_caselist_kill (ffestb_local_.case_stmt.cases); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CASE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R1001 -- Parse a FORMAT statement + + return ffestb_R1001; // to lexer + + Make sure the statement has a valid form for an FORMAT statement. + If it does, implement the statement. */ + +ffelexHandler +ffestb_R1001 (ffelexToken t) +{ + ffesttFormatList f; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstFORMAT) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstFORMAT) + goto bad_0; /* :::::::::::::::::::: */ + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlFORMAT) + goto bad_0; /* :::::::::::::::::::: */ + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + ffestb_local_.format.complained = FALSE; + ffestb_local_.format.f = NULL; /* No parent yet. */ + ffestb_local_.format.f = ffestt_formatlist_create (NULL, + ffelex_token_use (t)); + ffelex_set_names_pure (TRUE); /* Have even free-form lexer give us + NAMES. */ + return (ffelexHandler) ffestb_R10011_; + + case FFELEX_typeOPEN_ARRAY:/* "(/". */ + ffesta_confirmed (); + ffestb_local_.format.complained = FALSE; + ffestb_local_.format.f = ffestt_formatlist_create (NULL, + ffelex_token_use (t)); + f = ffestt_formatlist_append (ffestb_local_.format.f); + f->type = FFESTP_formattypeSLASH; + f->t = ffelex_token_use (t); + f->u.R1010.val.present = FALSE; + f->u.R1010.val.rtexpr = FALSE; + f->u.R1010.val.t = NULL; + f->u.R1010.val.u.unsigned_val = 1; + ffelex_set_names_pure (TRUE); /* Have even free-form lexer give us + NAMES. */ + return (ffelexHandler) ffestb_R100112_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_R10011_ -- "FORMAT" OPEN_PAREN expr + + return ffestb_R10011_; // to lexer + + For CLOSE_PAREN, wrap up the format list and if it is the top-level one, + exit. For anything else, pass it to _2_. */ + +static ffelexHandler +ffestb_R10011_ (ffelexToken t) +{ + ffesttFormatList f; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + break; + + default: + return (ffelexHandler) ffestb_R10012_ (t); + } + + /* If we have a format we're working on, continue working on it. */ + + f = ffestb_local_.format.f->u.root.parent; + + if (f != NULL) + { + ffestb_local_.format.f = f->next; + return (ffelexHandler) ffestb_R100111_; + } + + return (ffelexHandler) ffestb_R100114_; +} + +/* ffestb_R10012_ -- "FORMAT" OPEN_PAREN [format-item-list] + + return ffestb_R10012_; // to lexer + + The initial state for a format-item. Here, just handle the initial + number, sign for number, or run-time expression. Also handle spurious + comma, close-paren (indicating spurious comma), close-array (like + close-paren but preceded by slash), and quoted strings. */ + +static ffelexHandler +ffestb_R10012_ (ffelexToken t) +{ + unsigned long unsigned_val; + ffesttFormatList f; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_ANGLE: + ffesta_confirmed (); + ffestb_local_.format.pre.t = ffelex_token_use (t); + ffelex_set_names_pure (FALSE); + if (!ffesta_seen_first_exec && !ffestb_local_.format.complained) + { + ffestb_local_.format.complained = TRUE; + ffebad_start (FFEBAD_FORMAT_EXPR_SPEC); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFORMAT, (ffeexprCallback) ffestb_R100115_); + + case FFELEX_typeNUMBER: + ffestb_local_.format.sign = FALSE; /* No sign present. */ + ffestb_local_.format.pre.present = TRUE; + ffestb_local_.format.pre.rtexpr = FALSE; + ffestb_local_.format.pre.t = ffelex_token_use (t); + ffestb_local_.format.pre.u.unsigned_val = unsigned_val + = strtoul (ffelex_token_text (t), NULL, 10); + ffelex_set_expecting_hollerith (unsigned_val, '\0', + ffelex_token_where_line (t), + ffelex_token_where_column (t)); + return (ffelexHandler) ffestb_R10014_; + + case FFELEX_typePLUS: + ffestb_local_.format.sign = TRUE; /* Positive. */ + ffestb_local_.format.pre.t = ffelex_token_use (t); + return (ffelexHandler) ffestb_R10013_; + + case FFELEX_typeMINUS: + ffestb_local_.format.sign = FALSE; /* Negative. */ + ffestb_local_.format.pre.t = ffelex_token_use (t); + return (ffelexHandler) ffestb_R10013_; + + case FFELEX_typeCOLON: + case FFELEX_typeCOLONCOLON:/* "::". */ + case FFELEX_typeSLASH: + case FFELEX_typeCONCAT: /* "//". */ + case FFELEX_typeNAMES: + case FFELEX_typeDOLLAR: + case FFELEX_typeOPEN_PAREN: + case FFELEX_typeOPEN_ARRAY:/* "(/". */ + ffestb_local_.format.sign = FALSE; /* No sign present. */ + ffestb_local_.format.pre.present = FALSE; + ffestb_local_.format.pre.rtexpr = FALSE; + ffestb_local_.format.pre.t = NULL; + ffestb_local_.format.pre.u.unsigned_val = 1; + return (ffelexHandler) ffestb_R10014_ (t); + + case FFELEX_typeCOMMA: + ffebad_start (FFEBAD_FORMAT_EXTRA_COMMA); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + return (ffelexHandler) ffestb_R10012_; + + case FFELEX_typeCLOSE_PAREN: + ffebad_start (FFEBAD_FORMAT_EXTRA_COMMA); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + f = ffestb_local_.format.f->u.root.parent; + if (f == NULL) + return (ffelexHandler) ffestb_R100114_; + ffestb_local_.format.f = f->next; + return (ffelexHandler) ffestb_R100111_; + + case FFELEX_typeCLOSE_ARRAY: /* "/)". */ + f = ffestt_formatlist_append (ffestb_local_.format.f); + f->type = FFESTP_formattypeSLASH; + f->t = ffelex_token_use (t); + f->u.R1010.val.present = FALSE; + f->u.R1010.val.rtexpr = FALSE; + f->u.R1010.val.t = NULL; + f->u.R1010.val.u.unsigned_val = 1; + f = ffestb_local_.format.f->u.root.parent; + if (f == NULL) + return (ffelexHandler) ffestb_R100114_; + ffestb_local_.format.f = f->next; + return (ffelexHandler) ffestb_R100111_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_PAREN, t); + for (f = ffestb_local_.format.f; + f->u.root.parent != NULL; + f = f->u.root.parent->next) + ; + ffestb_local_.format.f = f; + return (ffelexHandler) ffestb_R100114_ (t); + + case FFELEX_typeQUOTE: + if (ffe_is_vxt ()) + break; /* Error, probably something like FORMAT("17) + = X. */ + ffelex_set_expecting_hollerith (-1, '\"', + ffelex_token_where_line (t), + ffelex_token_where_column (t)); /* Don't have to unset + this one. */ + return (ffelexHandler) ffestb_R100113_; + + case FFELEX_typeAPOSTROPHE: +#if 0 /* No apparent need for this, and not killed + anywhere. */ + ffesta_tokens[1] = ffelex_token_use (t); +#endif + ffelex_set_expecting_hollerith (-1, '\'', + ffelex_token_where_line (t), + ffelex_token_where_column (t)); /* Don't have to unset + this one. */ + return (ffelexHandler) ffestb_R100113_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t); + ffestt_formatlist_kill (ffestb_local_.format.f); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R10013_ -- "FORMAT" OPEN_PAREN [format-item-list] PLUS/MINUS + + return ffestb_R10013_; // to lexer + + Expect a NUMBER or complain about and then ignore the PLUS/MINUS. */ + +static ffelexHandler +ffestb_R10013_ (ffelexToken t) +{ + unsigned long unsigned_val; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + ffestb_local_.format.pre.present = TRUE; + ffestb_local_.format.pre.rtexpr = FALSE; + unsigned_val = strtoul (ffelex_token_text (t), NULL, 10); + ffestb_local_.format.pre.u.signed_val = ffestb_local_.format.sign + ? unsigned_val : -unsigned_val; + ffestb_local_.format.sign = TRUE; /* Sign present. */ + return (ffelexHandler) ffestb_R10014_; + + default: + ffebad_start (FFEBAD_FORMAT_SPURIOUS_SIGN); + ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t), + ffelex_token_where_column (ffestb_local_.format.pre.t)); + ffebad_finish (); + ffelex_token_kill (ffestb_local_.format.pre.t); + return (ffelexHandler) ffestb_R10012_ (t); + } +} + +/* ffestb_R10014_ -- "FORMAT" OPEN_PAREN [format-item-list] [[+/-] NUMBER] + + return ffestb_R10014_; // to lexer + + Here is where we expect to see the actual NAMES, COLON, SLASH, OPEN_PAREN, + OPEN_ARRAY, COLONCOLON, CONCAT, DOLLAR, or HOLLERITH that identifies what + kind of format-item we're dealing with. But if we see a NUMBER instead, it + means free-form spaces number like "5 6 X", so scale the current number + accordingly and reenter this state. (I really wouldn't be surprised if + they change this spacing rule in the F90 spec so that you can't embed + spaces within numbers or within keywords like BN in a free-source-form + program.) */ + +static ffelexHandler +ffestb_R10014_ (ffelexToken t) +{ + ffesttFormatList f; + ffeTokenLength i; + char *p; + ffestrFormat kw; + + ffelex_set_expecting_hollerith (0, '\0', + ffewhere_line_unknown (), + ffewhere_column_unknown ()); + + switch (ffelex_token_type (t)) + { + case FFELEX_typeHOLLERITH: + f = ffestt_formatlist_append (ffestb_local_.format.f); + f->type = FFESTP_formattypeR1016; + f->t = ffelex_token_use (t); + ffelex_token_kill (ffestb_local_.format.pre.t); /* It WAS present! */ + return (ffelexHandler) ffestb_R100111_; + + case FFELEX_typeNUMBER: + assert (ffestb_local_.format.pre.present); + ffesta_confirmed (); + if (ffestb_local_.format.pre.rtexpr) + { + ffebad_start (FFEBAD_FORMAT_SPURIOUS_NUMBER); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + return (ffelexHandler) ffestb_R10014_; + } + if (ffestb_local_.format.sign) + { + for (i = 0; i < ffelex_token_length (t); ++i) + ffestb_local_.format.pre.u.signed_val *= 10; + ffestb_local_.format.pre.u.signed_val += strtoul (ffelex_token_text (t), + NULL, 10); + } + else + { + for (i = 0; i < ffelex_token_length (t); ++i) + ffestb_local_.format.pre.u.unsigned_val *= 10; + ffestb_local_.format.pre.u.unsigned_val += strtoul (ffelex_token_text (t), + NULL, 10); + ffelex_set_expecting_hollerith (ffestb_local_.format.pre.u.unsigned_val, + '\0', + ffelex_token_where_line (t), + ffelex_token_where_column (t)); + } + return (ffelexHandler) ffestb_R10014_; + + case FFELEX_typeCOLONCOLON: /* "::". */ + if (ffestb_local_.format.pre.present) + { + ffesta_ffebad_1t (FFEBAD_FORMAT_BAD_COLON_SPEC, + ffestb_local_.format.pre.t); + ffelex_token_kill (ffestb_local_.format.pre.t); + ffestb_local_.format.pre.present = FALSE; + } + else + { + f = ffestt_formatlist_append (ffestb_local_.format.f); + f->type = FFESTP_formattypeCOLON; + f->t = ffelex_token_use (t); + f->u.R1010.val.present = FALSE; + f->u.R1010.val.rtexpr = FALSE; + f->u.R1010.val.t = NULL; + f->u.R1010.val.u.unsigned_val = 1; + } + f = ffestt_formatlist_append (ffestb_local_.format.f); + f->type = FFESTP_formattypeCOLON; + f->t = ffelex_token_use (t); + f->u.R1010.val.present = FALSE; + f->u.R1010.val.rtexpr = FALSE; + f->u.R1010.val.t = NULL; + f->u.R1010.val.u.unsigned_val = 1; + return (ffelexHandler) ffestb_R100112_; + + case FFELEX_typeCOLON: + if (ffestb_local_.format.pre.present) + { + ffesta_ffebad_1t (FFEBAD_FORMAT_BAD_COLON_SPEC, + ffestb_local_.format.pre.t); + ffelex_token_kill (ffestb_local_.format.pre.t); + return (ffelexHandler) ffestb_R100112_; + } + f = ffestt_formatlist_append (ffestb_local_.format.f); + f->type = FFESTP_formattypeCOLON; + f->t = ffelex_token_use (t); + f->u.R1010.val.present = FALSE; + f->u.R1010.val.rtexpr = FALSE; + f->u.R1010.val.t = NULL; + f->u.R1010.val.u.unsigned_val = 1; + return (ffelexHandler) ffestb_R100112_; + + case FFELEX_typeCONCAT: /* "//". */ + if (ffestb_local_.format.sign) + { + ffebad_start (FFEBAD_FORMAT_SPURIOUS_SIGN); + ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t), + ffelex_token_where_column (ffestb_local_.format.pre.t)); + ffebad_finish (); + ffestb_local_.format.pre.u.unsigned_val + = (ffestb_local_.format.pre.u.signed_val < 0) + ? -ffestb_local_.format.pre.u.signed_val + : ffestb_local_.format.pre.u.signed_val; + } + f = ffestt_formatlist_append (ffestb_local_.format.f); + f->type = FFESTP_formattypeSLASH; + f->t = ffelex_token_use (t); + f->u.R1010.val = ffestb_local_.format.pre; + ffestb_local_.format.pre.present = FALSE; + ffestb_local_.format.pre.rtexpr = FALSE; + ffestb_local_.format.pre.t = NULL; + ffestb_local_.format.pre.u.unsigned_val = 1; + f = ffestt_formatlist_append (ffestb_local_.format.f); + f->type = FFESTP_formattypeSLASH; + f->t = ffelex_token_use (t); + f->u.R1010.val = ffestb_local_.format.pre; + return (ffelexHandler) ffestb_R100112_; + + case FFELEX_typeSLASH: + if (ffestb_local_.format.sign) + { + ffebad_start (FFEBAD_FORMAT_SPURIOUS_SIGN); + ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t), + ffelex_token_where_column (ffestb_local_.format.pre.t)); + ffebad_finish (); + ffestb_local_.format.pre.u.unsigned_val + = (ffestb_local_.format.pre.u.signed_val < 0) + ? -ffestb_local_.format.pre.u.signed_val + : ffestb_local_.format.pre.u.signed_val; + } + f = ffestt_formatlist_append (ffestb_local_.format.f); + f->type = FFESTP_formattypeSLASH; + f->t = ffelex_token_use (t); + f->u.R1010.val = ffestb_local_.format.pre; + return (ffelexHandler) ffestb_R100112_; + + case FFELEX_typeOPEN_PAREN: + if (ffestb_local_.format.sign) + { + ffebad_start (FFEBAD_FORMAT_SPURIOUS_SIGN); + ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t), + ffelex_token_where_column (ffestb_local_.format.pre.t)); + ffebad_finish (); + ffestb_local_.format.pre.u.unsigned_val + = (ffestb_local_.format.pre.u.signed_val < 0) + ? -ffestb_local_.format.pre.u.signed_val + : ffestb_local_.format.pre.u.signed_val; + } + f = ffestt_formatlist_append (ffestb_local_.format.f); + f->type = FFESTP_formattypeFORMAT; + f->t = ffelex_token_use (t); + f->u.R1003D.R1004 = ffestb_local_.format.pre; + f->u.R1003D.format = ffestb_local_.format.f + = ffestt_formatlist_create (f, ffelex_token_use (t)); + return (ffelexHandler) ffestb_R10011_; + + case FFELEX_typeOPEN_ARRAY:/* "(/". */ + if (ffestb_local_.format.sign) + { + ffebad_start (FFEBAD_FORMAT_SPURIOUS_SIGN); + ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t), + ffelex_token_where_column (ffestb_local_.format.pre.t)); + ffebad_finish (); + ffestb_local_.format.pre.u.unsigned_val + = (ffestb_local_.format.pre.u.signed_val < 0) + ? -ffestb_local_.format.pre.u.signed_val + : ffestb_local_.format.pre.u.signed_val; + } + f = ffestt_formatlist_append (ffestb_local_.format.f); + f->type = FFESTP_formattypeFORMAT; + f->t = ffelex_token_use (t); + f->u.R1003D.R1004 = ffestb_local_.format.pre; + f->u.R1003D.format = ffestb_local_.format.f + = ffestt_formatlist_create (f, ffelex_token_use (t)); + f = ffestt_formatlist_append (ffestb_local_.format.f); + f->type = FFESTP_formattypeSLASH; + f->t = ffelex_token_use (t); + f->u.R1010.val.present = FALSE; + f->u.R1010.val.rtexpr = FALSE; + f->u.R1010.val.t = NULL; + f->u.R1010.val.u.unsigned_val = 1; + return (ffelexHandler) ffestb_R100112_; + + case FFELEX_typeCLOSE_ARRAY: /* "/)". */ + f = ffestt_formatlist_append (ffestb_local_.format.f); + f->type = FFESTP_formattypeSLASH; + f->t = ffelex_token_use (t); + f->u.R1010.val = ffestb_local_.format.pre; + f = ffestb_local_.format.f->u.root.parent; + if (f == NULL) + return (ffelexHandler) ffestb_R100114_; + ffestb_local_.format.f = f->next; + return (ffelexHandler) ffestb_R100111_; + + case FFELEX_typeQUOTE: + if (ffe_is_vxt ()) + break; /* A totally bad character in a VXT FORMAT. */ + ffebad_start (FFEBAD_FORMAT_SPURIOUS_NUMBER); + ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t), + ffelex_token_where_column (ffestb_local_.format.pre.t)); + ffebad_finish (); + ffelex_token_kill (ffestb_local_.format.pre.t); + ffesta_confirmed (); +#if 0 /* No apparent need for this, and not killed + anywhere. */ + ffesta_tokens[1] = ffelex_token_use (t); +#endif + ffelex_set_expecting_hollerith (-1, '\"', + ffelex_token_where_line (t), + ffelex_token_where_column (t)); /* Don't have to unset + this one. */ + return (ffelexHandler) ffestb_R100113_; + + case FFELEX_typeAPOSTROPHE: + ffesta_confirmed (); + ffebad_start (FFEBAD_FORMAT_SPURIOUS_NUMBER); + ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t), + ffelex_token_where_column (ffestb_local_.format.pre.t)); + ffebad_finish (); + ffelex_token_kill (ffestb_local_.format.pre.t); +#if 0 /* No apparent need for this, and not killed + anywhere. */ + ffesta_tokens[1] = ffelex_token_use (t); +#endif + ffelex_set_expecting_hollerith (-1, '\'', ffelex_token_where_line (t), + ffelex_token_where_column (t)); /* Don't have to unset + this one. */ + return (ffelexHandler) ffestb_R100113_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_PAREN, t); + for (f = ffestb_local_.format.f; + f->u.root.parent != NULL; + f = f->u.root.parent->next) + ; + ffestb_local_.format.f = f; + ffelex_token_kill (ffestb_local_.format.pre.t); + return (ffelexHandler) ffestb_R100114_ (t); + + case FFELEX_typeDOLLAR: + ffestb_local_.format.t = ffelex_token_use (t); + if (ffestb_local_.format.pre.present) + ffesta_confirmed (); /* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeDOLLAR; + return (ffelexHandler) ffestb_R10015_; + + case FFELEX_typeNAMES: + kw = ffestr_format (t); + ffestb_local_.format.t = ffelex_token_use (t); + switch (kw) + { + case FFESTR_formatI: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeI; + i = FFESTR_formatlI; + break; + + case FFESTR_formatB: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeB; + i = FFESTR_formatlB; + break; + + case FFESTR_formatO: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeO; + i = FFESTR_formatlO; + break; + + case FFESTR_formatZ: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeZ; + i = FFESTR_formatlZ; + break; + + case FFESTR_formatF: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeF; + i = FFESTR_formatlF; + break; + + case FFESTR_formatE: + ffestb_local_.format.current = FFESTP_formattypeE; + i = FFESTR_formatlE; + break; + + case FFESTR_formatEN: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeEN; + i = FFESTR_formatlEN; + break; + + case FFESTR_formatG: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeG; + i = FFESTR_formatlG; + break; + + case FFESTR_formatL: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeL; + i = FFESTR_formatlL; + break; + + case FFESTR_formatA: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeA; + i = FFESTR_formatlA; + break; + + case FFESTR_formatD: + ffestb_local_.format.current = FFESTP_formattypeD; + i = FFESTR_formatlD; + break; + + case FFESTR_formatQ: + ffestb_local_.format.current = FFESTP_formattypeQ; + i = FFESTR_formatlQ; + break; + + case FFESTR_formatDOLLAR: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeDOLLAR; + i = FFESTR_formatlDOLLAR; + break; + + case FFESTR_formatP: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeP; + i = FFESTR_formatlP; + break; + + case FFESTR_formatT: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeT; + i = FFESTR_formatlT; + break; + + case FFESTR_formatTL: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeTL; + i = FFESTR_formatlTL; + break; + + case FFESTR_formatTR: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeTR; + i = FFESTR_formatlTR; + break; + + case FFESTR_formatX: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeX; + i = FFESTR_formatlX; + break; + + case FFESTR_formatS: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeS; + i = FFESTR_formatlS; + break; + + case FFESTR_formatSP: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeSP; + i = FFESTR_formatlSP; + break; + + case FFESTR_formatSS: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeSS; + i = FFESTR_formatlSS; + break; + + case FFESTR_formatBN: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeBN; + i = FFESTR_formatlBN; + break; + + case FFESTR_formatBZ: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeBZ; + i = FFESTR_formatlBZ; + break; + + case FFESTR_formatH: /* Error, either "H" or "H". */ + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeH; + i = FFESTR_formatlH; + break; + + case FFESTR_formatPD: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_subr_R1001_append_p_ (); + ffestb_local_.format.t = ffelex_token_name_from_names (t, + FFESTR_formatlP, 1); + ffestb_local_.format.sign = FALSE; + ffestb_local_.format.pre.present = FALSE; + ffestb_local_.format.pre.rtexpr = FALSE; + ffestb_local_.format.pre.t = NULL; + ffestb_local_.format.pre.u.unsigned_val = 1; + ffestb_local_.format.current = FFESTP_formattypeD; + i = FFESTR_formatlPD; + break; + + case FFESTR_formatPE: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_subr_R1001_append_p_ (); + ffestb_local_.format.t = ffelex_token_name_from_names (t, + FFESTR_formatlP, 1); + ffestb_local_.format.sign = FALSE; + ffestb_local_.format.pre.present = FALSE; + ffestb_local_.format.pre.rtexpr = FALSE; + ffestb_local_.format.pre.t = NULL; + ffestb_local_.format.pre.u.unsigned_val = 1; + ffestb_local_.format.current = FFESTP_formattypeE; + i = FFESTR_formatlPE; + break; + + case FFESTR_formatPEN: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_subr_R1001_append_p_ (); + ffestb_local_.format.t = ffelex_token_name_from_names (t, + FFESTR_formatlP, 1); + ffestb_local_.format.sign = FALSE; + ffestb_local_.format.pre.present = FALSE; + ffestb_local_.format.pre.rtexpr = FALSE; + ffestb_local_.format.pre.t = NULL; + ffestb_local_.format.pre.u.unsigned_val = 1; + ffestb_local_.format.current = FFESTP_formattypeEN; + i = FFESTR_formatlPEN; + break; + + case FFESTR_formatPF: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_subr_R1001_append_p_ (); + ffestb_local_.format.t = ffelex_token_name_from_names (t, + FFESTR_formatlP, 1); + ffestb_local_.format.sign = FALSE; + ffestb_local_.format.pre.present = FALSE; + ffestb_local_.format.pre.rtexpr = FALSE; + ffestb_local_.format.pre.t = NULL; + ffestb_local_.format.pre.u.unsigned_val = 1; + ffestb_local_.format.current = FFESTP_formattypeF; + i = FFESTR_formatlPF; + break; + + case FFESTR_formatPG: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_subr_R1001_append_p_ (); + ffestb_local_.format.t = ffelex_token_name_from_names (t, + FFESTR_formatlP, 1); + ffestb_local_.format.sign = FALSE; + ffestb_local_.format.pre.present = FALSE; + ffestb_local_.format.pre.rtexpr = FALSE; + ffestb_local_.format.pre.t = NULL; + ffestb_local_.format.pre.u.unsigned_val = 1; + ffestb_local_.format.current = FFESTP_formattypeG; + i = FFESTR_formatlPG; + break; + + default: + if (ffestb_local_.format.pre.present) + ffesta_confirmed ();/* Number preceding this invalid elsewhere. */ + ffestb_local_.format.current = FFESTP_formattypeNone; + p = strpbrk (ffelex_token_text (t), "0123456789"); + if (p == NULL) + i = ffelex_token_length (t); + else + i = p - ffelex_token_text (t); + break; + } + p = ffelex_token_text (t) + i; + if (*p == '\0') + return (ffelexHandler) ffestb_R10015_; + if (!isdigit (*p)) + { + if (ffestb_local_.format.current == FFESTP_formattypeH) + p = strpbrk (p, "0123456789"); + else + { + p = NULL; + ffestb_local_.format.current = FFESTP_formattypeNone; + } + if (p == NULL) + return (ffelexHandler) ffestb_R10015_; + i = p - ffelex_token_text (t); /* Collect digits. */ + } + ffestb_local_.format.post.present = TRUE; + ffestb_local_.format.post.rtexpr = FALSE; + ffestb_local_.format.post.t = ffelex_token_number_from_names (t, i); + ffestb_local_.format.post.u.unsigned_val + = strtoul (ffelex_token_text (ffestb_local_.format.post.t), NULL, 10); + p += ffelex_token_length (ffestb_local_.format.post.t); + i += ffelex_token_length (ffestb_local_.format.post.t); + if (*p == '\0') + return (ffelexHandler) ffestb_R10016_; + if ((kw != FFESTR_formatP) || !ffelex_is_firstnamechar (*p)) + { + if (ffestb_local_.format.current != FFESTP_formattypeH) + ffesta_ffebad_1p (FFEBAD_FORMAT_TEXT_IN_NUMBER, t, i, NULL); + return (ffelexHandler) ffestb_R10016_; + } + + /* Here we have [number]P[number][text]. Treat as + [number]P,[number][text]. */ + + ffestb_subr_R1001_append_p_ (); + t = ffestb_local_.format.t = ffelex_token_names_from_names (t, i, 0); + ffestb_local_.format.sign = FALSE; + ffestb_local_.format.pre = ffestb_local_.format.post; + kw = ffestr_format (t); + switch (kw) + { /* Only a few possibilities here. */ + case FFESTR_formatD: + ffestb_local_.format.current = FFESTP_formattypeD; + i = FFESTR_formatlD; + break; + + case FFESTR_formatE: + ffestb_local_.format.current = FFESTP_formattypeE; + i = FFESTR_formatlE; + break; + + case FFESTR_formatEN: + ffestb_local_.format.current = FFESTP_formattypeEN; + i = FFESTR_formatlEN; + break; + + case FFESTR_formatF: + ffestb_local_.format.current = FFESTP_formattypeF; + i = FFESTR_formatlF; + break; + + case FFESTR_formatG: + ffestb_local_.format.current = FFESTP_formattypeG; + i = FFESTR_formatlG; + break; + + default: + ffebad_start (FFEBAD_FORMAT_P_NOCOMMA); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + ffestb_local_.format.current = FFESTP_formattypeNone; + p = strpbrk (ffelex_token_text (t), "0123456789"); + if (p == NULL) + i = ffelex_token_length (t); + else + i = p - ffelex_token_text (t); + } + p = ffelex_token_text (t) + i; + if (*p == '\0') + return (ffelexHandler) ffestb_R10015_; + if (!isdigit (*p)) + { + ffestb_local_.format.current = FFESTP_formattypeNone; + p = strpbrk (p, "0123456789"); + if (p == NULL) + return (ffelexHandler) ffestb_R10015_; + i = p - ffelex_token_text (t); /* Collect digits anyway. */ + } + ffestb_local_.format.post.present = TRUE; + ffestb_local_.format.post.rtexpr = FALSE; + ffestb_local_.format.post.t = ffelex_token_number_from_names (t, i); + ffestb_local_.format.post.u.unsigned_val + = strtoul (ffelex_token_text (ffestb_local_.format.post.t), NULL, 10); + p += ffelex_token_length (ffestb_local_.format.post.t); + i += ffelex_token_length (ffestb_local_.format.post.t); + if (*p == '\0') + return (ffelexHandler) ffestb_R10016_; + ffesta_ffebad_1p (FFEBAD_FORMAT_TEXT_IN_NUMBER, t, i, NULL); + return (ffelexHandler) ffestb_R10016_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t); + if (ffestb_local_.format.pre.present) + ffelex_token_kill (ffestb_local_.format.pre.t); + ffestt_formatlist_kill (ffestb_local_.format.f); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); +} + +/* ffestb_R10015_ -- [[+/-] NUMBER] NAMES + + return ffestb_R10015_; // to lexer + + Here we've gotten at least the initial mnemonic for the edit descriptor. + We expect either a NUMBER, for the post-mnemonic value, a NAMES, for + further clarification (in free-form only, sigh) of the mnemonic, or + anything else. In all cases we go to _6_, with the difference that for + NUMBER and NAMES we send the next token rather than the current token. */ + +static ffelexHandler +ffestb_R10015_ (ffelexToken t) +{ + bool split_pea; /* New NAMES requires splitting kP from new + edit desc. */ + ffestrFormat kw; + char *p; + ffeTokenLength i; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_ANGLE: + ffesta_confirmed (); + ffestb_local_.format.post.t = ffelex_token_use (t); + ffelex_set_names_pure (FALSE); + if (!ffesta_seen_first_exec && !ffestb_local_.format.complained) + { + ffestb_local_.format.complained = TRUE; + ffebad_start (FFEBAD_FORMAT_EXPR_SPEC); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFORMAT, (ffeexprCallback) ffestb_R100116_); + + case FFELEX_typeNUMBER: + ffestb_local_.format.post.present = TRUE; + ffestb_local_.format.post.rtexpr = FALSE; + ffestb_local_.format.post.t = ffelex_token_use (t); + ffestb_local_.format.post.u.unsigned_val + = strtoul (ffelex_token_text (t), NULL, 10); + return (ffelexHandler) ffestb_R10016_; + + case FFELEX_typeNAMES: + ffesta_confirmed (); /* NAMES " " NAMES invalid elsewhere in + free-form. */ + kw = ffestr_format (t); + switch (ffestb_local_.format.current) + { + case FFESTP_formattypeP: + split_pea = TRUE; + break; + + case FFESTP_formattypeH: /* An error, maintain this indicator. */ + kw = FFESTR_formatNone; + split_pea = FALSE; + break; + + default: + split_pea = FALSE; + break; + } + + switch (kw) + { + case FFESTR_formatF: + switch (ffestb_local_.format.current) + { + case FFESTP_formattypeP: + ffestb_local_.format.current = FFESTP_formattypeF; + break; + + default: + ffestb_local_.format.current = FFESTP_formattypeNone; + break; + } + i = FFESTR_formatlF; + break; + + case FFESTR_formatE: + switch (ffestb_local_.format.current) + { + case FFESTP_formattypeP: + ffestb_local_.format.current = FFESTP_formattypeE; + break; + + default: + ffestb_local_.format.current = FFESTP_formattypeNone; + break; + } + i = FFESTR_formatlE; + break; + + case FFESTR_formatEN: + switch (ffestb_local_.format.current) + { + case FFESTP_formattypeP: + ffestb_local_.format.current = FFESTP_formattypeEN; + break; + + default: + ffestb_local_.format.current = FFESTP_formattypeNone; + break; + } + i = FFESTR_formatlEN; + break; + + case FFESTR_formatG: + switch (ffestb_local_.format.current) + { + case FFESTP_formattypeP: + ffestb_local_.format.current = FFESTP_formattypeG; + break; + + default: + ffestb_local_.format.current = FFESTP_formattypeNone; + break; + } + i = FFESTR_formatlG; + break; + + case FFESTR_formatL: + switch (ffestb_local_.format.current) + { + case FFESTP_formattypeT: + ffestb_local_.format.current = FFESTP_formattypeTL; + break; + + default: + ffestb_local_.format.current = FFESTP_formattypeNone; + break; + } + i = FFESTR_formatlL; + break; + + case FFESTR_formatD: + switch (ffestb_local_.format.current) + { + case FFESTP_formattypeP: + ffestb_local_.format.current = FFESTP_formattypeD; + break; + + default: + ffestb_local_.format.current = FFESTP_formattypeNone; + break; + } + i = FFESTR_formatlD; + break; + + case FFESTR_formatS: + switch (ffestb_local_.format.current) + { + case FFESTP_formattypeS: + ffestb_local_.format.current = FFESTP_formattypeSS; + break; + + default: + ffestb_local_.format.current = FFESTP_formattypeNone; + break; + } + i = FFESTR_formatlS; + break; + + case FFESTR_formatP: + switch (ffestb_local_.format.current) + { + case FFESTP_formattypeS: + ffestb_local_.format.current = FFESTP_formattypeSP; + break; + + default: + ffestb_local_.format.current = FFESTP_formattypeNone; + break; + } + i = FFESTR_formatlP; + break; + + case FFESTR_formatR: + switch (ffestb_local_.format.current) + { + case FFESTP_formattypeT: + ffestb_local_.format.current = FFESTP_formattypeTR; + break; + + default: + ffestb_local_.format.current = FFESTP_formattypeNone; + break; + } + i = FFESTR_formatlR; + break; + + case FFESTR_formatZ: + switch (ffestb_local_.format.current) + { + case FFESTP_formattypeB: + ffestb_local_.format.current = FFESTP_formattypeBZ; + break; + + default: + ffestb_local_.format.current = FFESTP_formattypeNone; + break; + } + i = FFESTR_formatlZ; + break; + + case FFESTR_formatN: + switch (ffestb_local_.format.current) + { + case FFESTP_formattypeE: + ffestb_local_.format.current = FFESTP_formattypeEN; + break; + + case FFESTP_formattypeB: + ffestb_local_.format.current = FFESTP_formattypeBN; + break; + + default: + ffestb_local_.format.current = FFESTP_formattypeNone; + break; + } + i = FFESTR_formatlN; + break; + + default: + if (ffestb_local_.format.current != FFESTP_formattypeH) + ffestb_local_.format.current = FFESTP_formattypeNone; + split_pea = FALSE; /* Go ahead and let the P be in the party. */ + p = strpbrk (ffelex_token_text (t), "0123456789"); + if (p == NULL) + i = ffelex_token_length (t); + else + i = p - ffelex_token_text (t); + } + + if (split_pea) + { + ffestb_subr_R1001_append_p_ (); + ffestb_local_.format.t = ffelex_token_use (t); + ffestb_local_.format.sign = FALSE; + ffestb_local_.format.pre.present = FALSE; + ffestb_local_.format.pre.rtexpr = FALSE; + ffestb_local_.format.pre.t = NULL; + ffestb_local_.format.pre.u.unsigned_val = 1; + } + + p = ffelex_token_text (t) + i; + if (*p == '\0') + return (ffelexHandler) ffestb_R10015_; + if (!isdigit (*p)) + { + ffestb_local_.format.current = FFESTP_formattypeNone; + p = strpbrk (p, "0123456789"); + if (p == NULL) + return (ffelexHandler) ffestb_R10015_; + i = p - ffelex_token_text (t); /* Collect digits anyway. */ + } + ffestb_local_.format.post.present = TRUE; + ffestb_local_.format.post.rtexpr = FALSE; + ffestb_local_.format.post.t = ffelex_token_number_from_names (t, i); + ffestb_local_.format.post.u.unsigned_val + = strtoul (ffelex_token_text (ffestb_local_.format.post.t), NULL, 10); + p += ffelex_token_length (ffestb_local_.format.post.t); + i += ffelex_token_length (ffestb_local_.format.post.t); + if (*p == '\0') + return (ffelexHandler) ffestb_R10016_; + ffesta_ffebad_1p (FFEBAD_FORMAT_TEXT_IN_NUMBER, t, i, NULL); + return (ffelexHandler) ffestb_R10016_; + + default: + ffestb_local_.format.post.present = FALSE; + ffestb_local_.format.post.rtexpr = FALSE; + ffestb_local_.format.post.t = NULL; + ffestb_local_.format.post.u.unsigned_val = 1; + return (ffelexHandler) ffestb_R10016_ (t); + } +} + +/* ffestb_R10016_ -- [[+/-] NUMBER] NAMES NUMBER + + return ffestb_R10016_; // to lexer + + Expect a PERIOD here. Maybe find a NUMBER to append to the current + number, in which case return to this state. Maybe find a NAMES to switch + from a kP descriptor to a new descriptor (else the NAMES is spurious), + in which case generator the P item and go to state _4_. Anything + else, pass token on to state _8_. */ + +static ffelexHandler +ffestb_R10016_ (ffelexToken t) +{ + ffeTokenLength i; + + switch (ffelex_token_type (t)) + { + case FFELEX_typePERIOD: + return (ffelexHandler) ffestb_R10017_; + + case FFELEX_typeNUMBER: + assert (ffestb_local_.format.post.present); + ffesta_confirmed (); + if (ffestb_local_.format.post.rtexpr) + { + ffebad_start (FFEBAD_FORMAT_SPURIOUS_NUMBER); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + return (ffelexHandler) ffestb_R10016_; + } + for (i = 0; i < ffelex_token_length (t); ++i) + ffestb_local_.format.post.u.unsigned_val *= 10; + ffestb_local_.format.post.u.unsigned_val += strtoul (ffelex_token_text (t), + NULL, 10); + return (ffelexHandler) ffestb_R10016_; + + case FFELEX_typeNAMES: + ffesta_confirmed (); /* NUMBER " " NAMES invalid elsewhere. */ + if (ffestb_local_.format.current != FFESTP_formattypeP) + { + ffesta_ffebad_1t (FFEBAD_FORMAT_TEXT_IN_NUMBER, t); + return (ffelexHandler) ffestb_R10016_; + } + ffestb_subr_R1001_append_p_ (); + ffestb_local_.format.sign = FALSE; + ffestb_local_.format.pre = ffestb_local_.format.post; + return (ffelexHandler) ffestb_R10014_ (t); + + default: + ffestb_local_.format.dot.present = FALSE; + ffestb_local_.format.dot.rtexpr = FALSE; + ffestb_local_.format.dot.t = NULL; + ffestb_local_.format.dot.u.unsigned_val = 1; + return (ffelexHandler) ffestb_R10018_ (t); + } +} + +/* ffestb_R10017_ -- [[+/-] NUMBER] NAMES NUMBER PERIOD + + return ffestb_R10017_; // to lexer + + Here we've gotten the period following the edit descriptor. + We expect either a NUMBER, for the dot value, or something else, which + probably means we're not even close to being in a real FORMAT statement. */ + +static ffelexHandler +ffestb_R10017_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_ANGLE: + ffestb_local_.format.dot.t = ffelex_token_use (t); + ffelex_set_names_pure (FALSE); + if (!ffesta_seen_first_exec && !ffestb_local_.format.complained) + { + ffestb_local_.format.complained = TRUE; + ffebad_start (FFEBAD_FORMAT_EXPR_SPEC); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFORMAT, (ffeexprCallback) ffestb_R100117_); + + case FFELEX_typeNUMBER: + ffestb_local_.format.dot.present = TRUE; + ffestb_local_.format.dot.rtexpr = FALSE; + ffestb_local_.format.dot.t = ffelex_token_use (t); + ffestb_local_.format.dot.u.unsigned_val + = strtoul (ffelex_token_text (t), NULL, 10); + return (ffelexHandler) ffestb_R10018_; + + default: + ffelex_token_kill (ffestb_local_.format.t); + if (ffestb_local_.format.pre.present) + ffelex_token_kill (ffestb_local_.format.pre.t); + if (ffestb_local_.format.post.present) + ffelex_token_kill (ffestb_local_.format.post.t); + ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_DOT, t); + ffestt_formatlist_kill (ffestb_local_.format.f); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + } +} + +/* ffestb_R10018_ -- [[+/-] NUMBER] NAMES NUMBER PERIOD NUMBER + + return ffestb_R10018_; // to lexer + + Expect a NAMES here, which must begin with "E" to be valid. Maybe find a + NUMBER to append to the current number, in which case return to this state. + Anything else, pass token on to state _10_. */ + +static ffelexHandler +ffestb_R10018_ (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + assert (ffestb_local_.format.dot.present); + ffesta_confirmed (); + if (ffestb_local_.format.dot.rtexpr) + { + ffebad_start (FFEBAD_FORMAT_SPURIOUS_NUMBER); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + return (ffelexHandler) ffestb_R10018_; + } + for (i = 0; i < ffelex_token_length (t); ++i) + ffestb_local_.format.dot.u.unsigned_val *= 10; + ffestb_local_.format.dot.u.unsigned_val += strtoul (ffelex_token_text (t), + NULL, 10); + return (ffelexHandler) ffestb_R10018_; + + case FFELEX_typeNAMES: + if (!ffesrc_char_match_init (*(p = ffelex_token_text (t)), 'E', 'e')) + { + ffesta_ffebad_1t (FFEBAD_FORMAT_TEXT_IN_NUMBER, t); + return (ffelexHandler) ffestb_R10018_; + } + if (*++p == '\0') + return (ffelexHandler) ffestb_R10019_; /* Go get NUMBER. */ + i = 1; + if (!isdigit (*p)) + { + ffesta_ffebad_1p (FFEBAD_FORMAT_TEXT_IN_NUMBER, t, 1, NULL); + return (ffelexHandler) ffestb_R10018_; + } + ffestb_local_.format.exp.present = TRUE; + ffestb_local_.format.exp.rtexpr = FALSE; + ffestb_local_.format.exp.t = ffelex_token_number_from_names (t, i); + ffestb_local_.format.exp.u.unsigned_val + = strtoul (ffelex_token_text (ffestb_local_.format.exp.t), NULL, 10); + p += ffelex_token_length (ffestb_local_.format.exp.t); + i += ffelex_token_length (ffestb_local_.format.exp.t); + if (*p == '\0') + return (ffelexHandler) ffestb_R100110_; + ffesta_ffebad_1p (FFEBAD_FORMAT_TEXT_IN_NUMBER, t, i, NULL); + return (ffelexHandler) ffestb_R100110_; + + default: + ffestb_local_.format.exp.present = FALSE; + ffestb_local_.format.exp.rtexpr = FALSE; + ffestb_local_.format.exp.t = NULL; + ffestb_local_.format.exp.u.unsigned_val = 1; + return (ffelexHandler) ffestb_R100110_ (t); + } +} + +/* ffestb_R10019_ -- [[+/-] NUMBER] NAMES NUMBER PERIOD NUMBER "E" + + return ffestb_R10019_; // to lexer + + Here we've gotten the "E" following the edit descriptor. + We expect either a NUMBER, for the exponent value, or something else. */ + +static ffelexHandler +ffestb_R10019_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_ANGLE: + ffestb_local_.format.exp.t = ffelex_token_use (t); + ffelex_set_names_pure (FALSE); + if (!ffesta_seen_first_exec && !ffestb_local_.format.complained) + { + ffestb_local_.format.complained = TRUE; + ffebad_start (FFEBAD_FORMAT_EXPR_SPEC); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + } + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFORMAT, (ffeexprCallback) ffestb_R100118_); + + case FFELEX_typeNUMBER: + ffestb_local_.format.exp.present = TRUE; + ffestb_local_.format.exp.rtexpr = FALSE; + ffestb_local_.format.exp.t = ffelex_token_use (t); + ffestb_local_.format.exp.u.unsigned_val + = strtoul (ffelex_token_text (t), NULL, 10); + return (ffelexHandler) ffestb_R100110_; + + default: + ffelex_token_kill (ffestb_local_.format.t); + if (ffestb_local_.format.pre.present) + ffelex_token_kill (ffestb_local_.format.pre.t); + if (ffestb_local_.format.post.present) + ffelex_token_kill (ffestb_local_.format.post.t); + if (ffestb_local_.format.dot.present) + ffelex_token_kill (ffestb_local_.format.dot.t); + ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_EXP, t); + ffestt_formatlist_kill (ffestb_local_.format.f); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + } +} + +/* ffestb_R100110_ -- [[+/-] NUMBER] NAMES NUMBER [PERIOD NUMBER ["E" NUMBER]] + + return ffestb_R100110_; // to lexer + + Maybe find a NUMBER to append to the current number, in which case return + to this state. Anything else, handle current descriptor, then pass token + on to state _10_. */ + +static ffelexHandler +ffestb_R100110_ (ffelexToken t) +{ + ffeTokenLength i; + enum expect + { + required, + optional, + disallowed + }; + ffebad err; + enum expect pre; + enum expect post; + enum expect dot; + enum expect exp; + bool R1005; + ffesttFormatList f; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + assert (ffestb_local_.format.exp.present); + ffesta_confirmed (); + if (ffestb_local_.format.exp.rtexpr) + { + ffebad_start (FFEBAD_FORMAT_SPURIOUS_NUMBER); + ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t)); + ffebad_finish (); + return (ffelexHandler) ffestb_R100110_; + } + for (i = 0; i < ffelex_token_length (t); ++i) + ffestb_local_.format.exp.u.unsigned_val *= 10; + ffestb_local_.format.exp.u.unsigned_val += strtoul (ffelex_token_text (t), + NULL, 10); + return (ffelexHandler) ffestb_R100110_; + + default: + if (ffestb_local_.format.sign + && (ffestb_local_.format.current != FFESTP_formattypeP) + && (ffestb_local_.format.current != FFESTP_formattypeH)) + { + ffebad_start (FFEBAD_FORMAT_SPURIOUS_SIGN); + ffebad_here (0, ffelex_token_where_line (ffestb_local_.format.pre.t), + ffelex_token_where_column (ffestb_local_.format.pre.t)); + ffebad_finish (); + ffestb_local_.format.pre.u.unsigned_val + = (ffestb_local_.format.pre.u.signed_val < 0) + ? -ffestb_local_.format.pre.u.signed_val + : ffestb_local_.format.pre.u.signed_val; + } + switch (ffestb_local_.format.current) + { + case FFESTP_formattypeI: + err = FFEBAD_FORMAT_BAD_I_SPEC; + pre = optional; + post = required; + dot = optional; + exp = disallowed; + R1005 = TRUE; + break; + + case FFESTP_formattypeB: + err = FFEBAD_FORMAT_BAD_B_SPEC; + pre = optional; + post = required; + dot = optional; + exp = disallowed; + R1005 = TRUE; + break; + + case FFESTP_formattypeO: + err = FFEBAD_FORMAT_BAD_O_SPEC; + pre = optional; + post = required; + dot = optional; + exp = disallowed; + R1005 = TRUE; + break; + + case FFESTP_formattypeZ: + err = FFEBAD_FORMAT_BAD_Z_SPEC; + pre = optional; + post = required; + dot = optional; + exp = disallowed; + R1005 = TRUE; + break; + + case FFESTP_formattypeF: + err = FFEBAD_FORMAT_BAD_F_SPEC; + pre = optional; + post = required; + dot = required; + exp = disallowed; + R1005 = TRUE; + break; + + case FFESTP_formattypeE: + err = FFEBAD_FORMAT_BAD_E_SPEC; + pre = optional; + post = required; + dot = required; + exp = optional; + R1005 = TRUE; + break; + + case FFESTP_formattypeEN: + err = FFEBAD_FORMAT_BAD_EN_SPEC; + pre = optional; + post = required; + dot = required; + exp = optional; + R1005 = TRUE; + break; + + case FFESTP_formattypeG: + err = FFEBAD_FORMAT_BAD_G_SPEC; + pre = optional; + post = required; + dot = required; + exp = optional; + R1005 = TRUE; + break; + + case FFESTP_formattypeL: + err = FFEBAD_FORMAT_BAD_L_SPEC; + pre = optional; + post = required; + dot = disallowed; + exp = disallowed; + R1005 = TRUE; + break; + + case FFESTP_formattypeA: + err = FFEBAD_FORMAT_BAD_A_SPEC; + pre = optional; + post = optional; + dot = disallowed; + exp = disallowed; + R1005 = TRUE; + break; + + case FFESTP_formattypeD: + err = FFEBAD_FORMAT_BAD_D_SPEC; + pre = optional; + post = required; + dot = required; + exp = disallowed; + R1005 = TRUE; + break; + + case FFESTP_formattypeQ: + err = FFEBAD_FORMAT_BAD_Q_SPEC; + pre = disallowed; + post = disallowed; + dot = disallowed; + exp = disallowed; + R1005 = FALSE; + break; + + case FFESTP_formattypeDOLLAR: + err = FFEBAD_FORMAT_BAD_DOLLAR_SPEC; + pre = disallowed; + post = disallowed; + dot = disallowed; + exp = disallowed; + R1005 = FALSE; + break; + + case FFESTP_formattypeP: + err = FFEBAD_FORMAT_BAD_P_SPEC; + pre = required; + post = disallowed; + dot = disallowed; + exp = disallowed; + R1005 = FALSE; + break; + + case FFESTP_formattypeT: + err = FFEBAD_FORMAT_BAD_T_SPEC; + pre = disallowed; + post = required; + dot = disallowed; + exp = disallowed; + R1005 = FALSE; + break; + + case FFESTP_formattypeTL: + err = FFEBAD_FORMAT_BAD_TL_SPEC; + pre = disallowed; + post = required; + dot = disallowed; + exp = disallowed; + R1005 = FALSE; + break; + + case FFESTP_formattypeTR: + err = FFEBAD_FORMAT_BAD_TR_SPEC; + pre = disallowed; + post = required; + dot = disallowed; + exp = disallowed; + R1005 = FALSE; + break; + + case FFESTP_formattypeX: + err = FFEBAD_FORMAT_BAD_X_SPEC; + pre = required; + post = disallowed; + dot = disallowed; + exp = disallowed; + R1005 = FALSE; + break; + + case FFESTP_formattypeS: + err = FFEBAD_FORMAT_BAD_S_SPEC; + pre = disallowed; + post = disallowed; + dot = disallowed; + exp = disallowed; + R1005 = FALSE; + break; + + case FFESTP_formattypeSP: + err = FFEBAD_FORMAT_BAD_SP_SPEC; + pre = disallowed; + post = disallowed; + dot = disallowed; + exp = disallowed; + R1005 = FALSE; + break; + + case FFESTP_formattypeSS: + err = FFEBAD_FORMAT_BAD_SS_SPEC; + pre = disallowed; + post = disallowed; + dot = disallowed; + exp = disallowed; + R1005 = FALSE; + break; + + case FFESTP_formattypeBN: + err = FFEBAD_FORMAT_BAD_BN_SPEC; + pre = disallowed; + post = disallowed; + dot = disallowed; + exp = disallowed; + R1005 = FALSE; + break; + + case FFESTP_formattypeBZ: + err = FFEBAD_FORMAT_BAD_BZ_SPEC; + pre = disallowed; + post = disallowed; + dot = disallowed; + exp = disallowed; + R1005 = FALSE; + break; + + case FFESTP_formattypeH: /* Definitely an error, make sure of + it. */ + err = FFEBAD_FORMAT_BAD_H_SPEC; + pre = ffestb_local_.format.pre.present ? disallowed : required; + post = disallowed; + dot = disallowed; + exp = disallowed; + R1005 = FALSE; + break; + + case FFESTP_formattypeNone: + ffesta_ffebad_1t (FFEBAD_FORMAT_BAD_SPEC, + ffestb_local_.format.t); + + clean_up_to_11_: /* :::::::::::::::::::: */ + + ffelex_token_kill (ffestb_local_.format.t); + if (ffestb_local_.format.pre.present) + ffelex_token_kill (ffestb_local_.format.pre.t); + if (ffestb_local_.format.post.present) + ffelex_token_kill (ffestb_local_.format.post.t); + if (ffestb_local_.format.dot.present) + ffelex_token_kill (ffestb_local_.format.dot.t); + if (ffestb_local_.format.exp.present) + ffelex_token_kill (ffestb_local_.format.exp.t); + return (ffelexHandler) ffestb_R100111_ (t); + + default: + assert (FALSE); + err = FFEBAD_FORMAT_BAD_H_SPEC; + pre = disallowed; + post = disallowed; + dot = disallowed; + exp = disallowed; + R1005 = FALSE; + break; + } + if (((pre == disallowed) && ffestb_local_.format.pre.present) + || ((pre == required) && !ffestb_local_.format.pre.present)) + { + ffesta_ffebad_1t (err, (pre == required) + ? ffestb_local_.format.t : ffestb_local_.format.pre.t); + goto clean_up_to_11_; /* :::::::::::::::::::: */ + } + if (((post == disallowed) && ffestb_local_.format.post.present) + || ((post == required) && !ffestb_local_.format.post.present)) + { + ffesta_ffebad_1t (err, (post == required) + ? ffestb_local_.format.t : ffestb_local_.format.post.t); + goto clean_up_to_11_; /* :::::::::::::::::::: */ + } + if (((dot == disallowed) && ffestb_local_.format.dot.present) + || ((dot == required) && !ffestb_local_.format.dot.present)) + { + ffesta_ffebad_1t (err, (dot == required) + ? ffestb_local_.format.t : ffestb_local_.format.dot.t); + goto clean_up_to_11_; /* :::::::::::::::::::: */ + } + if (((exp == disallowed) && ffestb_local_.format.exp.present) + || ((exp == required) && !ffestb_local_.format.exp.present)) + { + ffesta_ffebad_1t (err, (exp == required) + ? ffestb_local_.format.t : ffestb_local_.format.exp.t); + goto clean_up_to_11_; /* :::::::::::::::::::: */ + } + f = ffestt_formatlist_append (ffestb_local_.format.f); + f->type = ffestb_local_.format.current; + f->t = ffestb_local_.format.t; + if (R1005) + { + f->u.R1005.R1004 = ffestb_local_.format.pre; + f->u.R1005.R1006 = ffestb_local_.format.post; + f->u.R1005.R1007_or_R1008 = ffestb_local_.format.dot; + f->u.R1005.R1009 = ffestb_local_.format.exp; + } + else + /* Must be R1010. */ + { + if (pre == disallowed) + f->u.R1010.val = ffestb_local_.format.post; + else + f->u.R1010.val = ffestb_local_.format.pre; + } + return (ffelexHandler) ffestb_R100111_ (t); + } +} + +/* ffestb_R100111_ -- edit-descriptor + + return ffestb_R100111_; // to lexer + + Expect a COMMA, CLOSE_PAREN, CLOSE_ARRAY, COLON, COLONCOLON, SLASH, or + CONCAT, or complain about missing comma. */ + +static ffelexHandler +ffestb_R100111_ (ffelexToken t) +{ + ffesttFormatList f; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_R10012_; + + case FFELEX_typeCOLON: + case FFELEX_typeCOLONCOLON: + case FFELEX_typeSLASH: + case FFELEX_typeCONCAT: + return (ffelexHandler) ffestb_R10012_ (t); + + case FFELEX_typeCLOSE_PAREN: + f = ffestb_local_.format.f->u.root.parent; + if (f == NULL) + return (ffelexHandler) ffestb_R100114_; + ffestb_local_.format.f = f->next; + return (ffelexHandler) ffestb_R100111_; + + case FFELEX_typeCLOSE_ARRAY: /* "/)". */ + f = ffestt_formatlist_append (ffestb_local_.format.f); + f->type = FFESTP_formattypeSLASH; + f->t = ffelex_token_use (t); + f->u.R1010.val.present = FALSE; + f->u.R1010.val.rtexpr = FALSE; + f->u.R1010.val.t = NULL; + f->u.R1010.val.u.unsigned_val = 1; + f = ffestb_local_.format.f->u.root.parent; + if (f == NULL) + return (ffelexHandler) ffestb_R100114_; + ffestb_local_.format.f = f->next; + return (ffelexHandler) ffestb_R100111_; + + case FFELEX_typeOPEN_ANGLE: + case FFELEX_typeDOLLAR: + case FFELEX_typeNUMBER: + case FFELEX_typeOPEN_PAREN: + case FFELEX_typeOPEN_ARRAY: + case FFELEX_typeQUOTE: + case FFELEX_typeAPOSTROPHE: + case FFELEX_typeNAMES: + ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_COMMA, t); + return (ffelexHandler) ffestb_R10012_ (t); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_PAREN, t); + for (f = ffestb_local_.format.f; + f->u.root.parent != NULL; + f = f->u.root.parent->next) + ; + ffestb_local_.format.f = f; + return (ffelexHandler) ffestb_R100114_ (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t); + ffestt_formatlist_kill (ffestb_local_.format.f); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + } +} + +/* ffestb_R100112_ -- COLON, COLONCOLON, SLASH, OPEN_ARRAY, or CONCAT + + return ffestb_R100112_; // to lexer + + Like _11_ except the COMMA is optional. */ + +static ffelexHandler +ffestb_R100112_ (ffelexToken t) +{ + ffesttFormatList f; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_R10012_; + + case FFELEX_typeCOLON: + case FFELEX_typeCOLONCOLON: + case FFELEX_typeSLASH: + case FFELEX_typeCONCAT: + case FFELEX_typeOPEN_ANGLE: + case FFELEX_typeNAMES: + case FFELEX_typeDOLLAR: + case FFELEX_typeNUMBER: + case FFELEX_typeOPEN_PAREN: + case FFELEX_typeOPEN_ARRAY: + case FFELEX_typeQUOTE: + case FFELEX_typeAPOSTROPHE: + case FFELEX_typePLUS: + case FFELEX_typeMINUS: + return (ffelexHandler) ffestb_R10012_ (t); + + case FFELEX_typeCLOSE_PAREN: + f = ffestb_local_.format.f->u.root.parent; + if (f == NULL) + return (ffelexHandler) ffestb_R100114_; + ffestb_local_.format.f = f->next; + return (ffelexHandler) ffestb_R100111_; + + case FFELEX_typeCLOSE_ARRAY: /* "/)". */ + f = ffestt_formatlist_append (ffestb_local_.format.f); + f->type = FFESTP_formattypeSLASH; + f->t = ffelex_token_use (t); + f->u.R1010.val.present = FALSE; + f->u.R1010.val.rtexpr = FALSE; + f->u.R1010.val.t = NULL; + f->u.R1010.val.u.unsigned_val = 1; + f = ffestb_local_.format.f->u.root.parent; + if (f == NULL) + return (ffelexHandler) ffestb_R100114_; + ffestb_local_.format.f = f->next; + return (ffelexHandler) ffestb_R100111_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + ffesta_ffebad_1t (FFEBAD_FORMAT_MISSING_PAREN, t); + for (f = ffestb_local_.format.f; + f->u.root.parent != NULL; + f = f->u.root.parent->next) + ; + ffestb_local_.format.f = f; + return (ffelexHandler) ffestb_R100114_ (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t); + ffestt_formatlist_kill (ffestb_local_.format.f); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + } +} + +/* ffestb_R100113_ -- Handle CHARACTER token. + + return ffestb_R100113_; // to lexer + + Append the format item to the list, go to _11_. */ + +static ffelexHandler +ffestb_R100113_ (ffelexToken t) +{ + ffesttFormatList f; + + assert (ffelex_token_type (t) == FFELEX_typeCHARACTER); + + if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0)) + { + ffebad_start (FFEBAD_NULL_CHAR_CONST); + ffebad_here (0, ffelex_token_where_line (t), + ffelex_token_where_column (t)); + ffebad_finish (); + } + + f = ffestt_formatlist_append (ffestb_local_.format.f); + f->type = FFESTP_formattypeR1016; + f->t = ffelex_token_use (t); + return (ffelexHandler) ffestb_R100111_; +} + +/* ffestb_R100114_ -- "FORMAT" OPEN_PAREN format-item-list CLOSE_PAREN + + return ffestb_R100114_; // to lexer + + Handle EOS/SEMICOLON or something else. */ + +static ffelexHandler +ffestb_R100114_ (ffelexToken t) +{ + ffelex_set_names_pure (FALSE); + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited () && !ffestb_local_.format.complained) + ffestc_R1001 (ffestb_local_.format.f); + ffestt_formatlist_kill (ffestb_local_.format.f); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t); + ffestt_formatlist_kill (ffestb_local_.format.f); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + } +} + +/* ffestb_R100115_ -- OPEN_ANGLE expr + + (ffestb_R100115_) // to expression handler + + Handle expression prior to the edit descriptor. */ + +static ffelexHandler +ffestb_R100115_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_ANGLE: + ffestb_local_.format.pre.present = TRUE; + ffestb_local_.format.pre.rtexpr = TRUE; + ffestb_local_.format.pre.u.expr = expr; + ffelex_set_names_pure (TRUE); + return (ffelexHandler) ffestb_R10014_; + + default: + ffelex_token_kill (ffestb_local_.format.pre.t); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t); + ffestt_formatlist_kill (ffestb_local_.format.f); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + } +} + +/* ffestb_R100116_ -- "[n]X" OPEN_ANGLE expr + + (ffestb_R100116_) // to expression handler + + Handle expression after the edit descriptor. */ + +static ffelexHandler +ffestb_R100116_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_ANGLE: + ffestb_local_.format.post.present = TRUE; + ffestb_local_.format.post.rtexpr = TRUE; + ffestb_local_.format.post.u.expr = expr; + ffelex_set_names_pure (TRUE); + return (ffelexHandler) ffestb_R10016_; + + default: + ffelex_token_kill (ffestb_local_.format.t); + ffelex_token_kill (ffestb_local_.format.post.t); + if (ffestb_local_.format.pre.present) + ffelex_token_kill (ffestb_local_.format.pre.t); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t); + ffestt_formatlist_kill (ffestb_local_.format.f); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + } +} + +/* ffestb_R100117_ -- "[n]X[n]." OPEN_ANGLE expr + + (ffestb_R100117_) // to expression handler + + Handle expression after the PERIOD. */ + +static ffelexHandler +ffestb_R100117_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_ANGLE: + ffestb_local_.format.dot.present = TRUE; + ffestb_local_.format.dot.rtexpr = TRUE; + ffestb_local_.format.dot.u.expr = expr; + ffelex_set_names_pure (TRUE); + return (ffelexHandler) ffestb_R10018_; + + default: + ffelex_token_kill (ffestb_local_.format.t); + ffelex_token_kill (ffestb_local_.format.dot.t); + if (ffestb_local_.format.pre.present) + ffelex_token_kill (ffestb_local_.format.pre.t); + if (ffestb_local_.format.post.present) + ffelex_token_kill (ffestb_local_.format.post.t); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t); + ffestt_formatlist_kill (ffestb_local_.format.f); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + } +} + +/* ffestb_R100118_ -- "[n]X[n].[n]E" OPEN_ANGLE expr + + (ffestb_R100118_) // to expression handler + + Handle expression after the "E". */ + +static ffelexHandler +ffestb_R100118_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_ANGLE: + ffestb_local_.format.exp.present = TRUE; + ffestb_local_.format.exp.rtexpr = TRUE; + ffestb_local_.format.exp.u.expr = expr; + ffelex_set_names_pure (TRUE); + return (ffelexHandler) ffestb_R100110_; + + default: + ffelex_token_kill (ffestb_local_.format.t); + ffelex_token_kill (ffestb_local_.format.exp.t); + if (ffestb_local_.format.pre.present) + ffelex_token_kill (ffestb_local_.format.pre.t); + if (ffestb_local_.format.post.present) + ffelex_token_kill (ffestb_local_.format.post.t); + if (ffestb_local_.format.dot.present) + ffelex_token_kill (ffestb_local_.format.dot.t); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FORMAT", t); + ffestt_formatlist_kill (ffestb_local_.format.f); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + } +} + +/* ffestb_R1107 -- Parse the USE statement + + return ffestb_R1107; // to lexer + + Make sure the statement has a valid form for the USE statement. + If it does, implement the statement. */ + +#if FFESTR_F90 +ffelexHandler +ffestb_R1107 (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstUSE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + ffesta_confirmed (); + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R11071_; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstUSE) + goto bad_0; /* :::::::::::::::::::: */ + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlUSE); + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeCOMMA: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + } + ffesta_confirmed (); + ffesta_tokens[1] + = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + return (ffelexHandler) ffestb_R11071_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "USE", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R11071_ -- "USE" NAME + + return ffestb_R11071_; // to lexer + + Make sure the statement has a valid form for the USE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R11071_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + { + ffestc_R1107_start (ffesta_tokens[1], FALSE); + ffestc_R1107_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_R11072_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R11072_ -- "USE" NAME COMMA + + return ffestb_R11072_; // to lexer + + Make sure the statement has a valid form for the USE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R11072_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[2] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R11073_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R11073_ -- "USE" NAME COMMA NAME + + return ffestb_R11073_; // to lexer + + Make sure the statement has a valid form for the USE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R11073_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOLON: + if (ffestr_other (ffesta_tokens[2]) != FFESTR_otherONLY) + break; + if (!ffesta_is_inhibited ()) + ffestc_R1107_start (ffesta_tokens[1], TRUE); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + return (ffelexHandler) ffestb_R11074_; + + case FFELEX_typePOINTS: + if (!ffesta_is_inhibited ()) + ffestc_R1107_start (ffesta_tokens[1], FALSE); + ffelex_token_kill (ffesta_tokens[1]); + ffesta_tokens[1] = ffesta_tokens[2]; + return (ffelexHandler) ffestb_R110711_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R11074_ -- "USE" NAME COMMA "ONLY" COLON + + return ffestb_R11074_; // to lexer + + Make sure the statement has a valid form for the USE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R11074_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R11075_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + ffestc_R1107_finish (); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t); + ffestc_R1107_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R11075_ -- "USE" NAME COMMA "ONLY" COLON NAME + + return ffestb_R11075_; // to lexer + + Make sure the statement has a valid form for the USE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R11075_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + { + ffestc_R1107_item (NULL, ffesta_tokens[1]); + ffestc_R1107_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeCOMMA: + if (!ffesta_is_inhibited ()) + ffestc_R1107_item (NULL, ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_R11078_; + + case FFELEX_typePOINTS: + return (ffelexHandler) ffestb_R11076_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t); + ffestc_R1107_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R11076_ -- "USE" NAME COMMA "ONLY" COLON NAME POINTS + + return ffestb_R11076_; // to lexer + + Make sure the statement has a valid form for the USE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R11076_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + if (!ffesta_is_inhibited ()) + ffestc_R1107_item (ffesta_tokens[1], t); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_R11077_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t); + ffestc_R1107_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R11077_ -- "USE" NAME COMMA "ONLY" COLON NAME POINTS NAME + + return ffestb_R11077_; // to lexer + + Make sure the statement has a valid form for the USE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R11077_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + ffestc_R1107_finish (); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_R11078_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t); + ffestc_R1107_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R11078_ -- "USE" NAME COMMA "ONLY" COLON NAME POINTS NAME COMMA + + return ffestb_R11078_; // to lexer + + Make sure the statement has a valid form for the USE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R11078_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R11075_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t); + ffestc_R1107_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R11079_ -- "USE" NAME COMMA + + return ffestb_R11079_; // to lexer + + Make sure the statement has a valid form for the USE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R11079_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R110710_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t); + ffestc_R1107_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R110710_ -- "USE" NAME COMMA NAME + + return ffestb_R110710_; // to lexer + + Make sure the statement has a valid form for the USE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R110710_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typePOINTS: + return (ffelexHandler) ffestb_R110711_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t); + ffestc_R1107_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R110711_ -- "USE" NAME COMMA NAME POINTS + + return ffestb_R110711_; // to lexer + + Make sure the statement has a valid form for the USE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R110711_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + if (!ffesta_is_inhibited ()) + ffestc_R1107_item (ffesta_tokens[1], t); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_R110712_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t); + ffestc_R1107_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R110712_ -- "USE" NAME COMMA NAME POINTS NAME + + return ffestb_R110712_; // to lexer + + Make sure the statement has a valid form for the USE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R110712_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + ffestc_R1107_finish (); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_R11079_; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "USE", t); + ffestc_R1107_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_R1202 -- Parse the INTERFACE statement + + return ffestb_R1202; // to lexer + + Make sure the statement has a valid form for the INTERFACE statement. + If it does, implement the statement. + + 15-May-90 JCB 1.1 + Allow INTERFACE by itself; missed this + valid form when originally doing syntactic analysis code. */ + +#if FFESTR_F90 +ffelexHandler +ffestb_R1202 (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstINTERFACE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R1202 (FFESTP_definedoperatorNone, NULL); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + ffesta_confirmed (); + switch (ffesta_second_kw) + { + case FFESTR_secondOPERATOR: + ffestb_local_.interface.operator = FFESTP_definedoperatorOPERATOR; + break; + + case FFESTR_secondASSIGNMENT: + ffestb_local_.interface.operator = FFESTP_definedoperatorASSIGNMENT; + break; + + default: + ffestb_local_.interface.operator = FFESTP_definedoperatorNone; + break; + } + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R12021_; + + case FFELEX_typeNAMES: + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlINTERFACE); + switch (ffesta_first_kw) + { + case FFESTR_firstINTERFACEOPERATOR: + if (*(ffelex_token_text (ffesta_tokens[0]) + + FFESTR_firstlINTERFACEOPERATOR) == '\0') + ffestb_local_.interface.operator + = FFESTP_definedoperatorOPERATOR; + break; + + case FFESTR_firstINTERFACEASSGNMNT: + if (*(ffelex_token_text (ffesta_tokens[0]) + + FFESTR_firstlINTERFACEASSGNMNT) == '\0') + ffestb_local_.interface.operator + = FFESTP_definedoperatorASSIGNMENT; + break; + + case FFESTR_firstINTERFACE: + ffestb_local_.interface.operator = FFESTP_definedoperatorNone; + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + case FFELEX_typeOPEN_ARRAY: /* Sigh. */ + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (*p == '\0') + { + if (!ffesta_is_inhibited ()) + ffestc_R1202 (FFESTP_definedoperatorNone, NULL); + return (ffelexHandler) ffesta_zero (t); + } + break; + } + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffesta_tokens[1] = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + return (ffelexHandler) ffestb_R12021_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INTERFACE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INTERFACE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "INTERFACE", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R12021_ -- "INTERFACE" NAME + + return ffestb_R12021_; // to lexer + + Make sure the statement has a valid form for the INTERFACE statement. If + it does, implement the statement. */ + +static ffelexHandler +ffestb_R12021_ (ffelexToken t) +{ + ffestb_local_.interface.slash = TRUE; /* Slash follows open paren. */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + ffestc_R1202 (FFESTP_definedoperatorNone, ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeOPEN_PAREN: + ffestb_local_.interface.slash = FALSE; /* Slash doesn't follow. */ + /* Fall through. */ + case FFELEX_typeOPEN_ARRAY: + switch (ffestb_local_.interface.operator) + { + case FFESTP_definedoperatorNone: + break; + + case FFESTP_definedoperatorOPERATOR: + ffestb_local_.interface.assignment = FALSE; + return (ffelexHandler) ffestb_R12022_; + + case FFESTP_definedoperatorASSIGNMENT: + ffestb_local_.interface.assignment = TRUE; + return (ffelexHandler) ffestb_R12022_; + + default: + assert (FALSE); + } + break; + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + break; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INTERFACE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R12022_ -- "INTERFACE" "OPERATOR/ASSIGNMENT" OPEN_PAREN + + return ffestb_R12022_; // to lexer + + Make sure the statement has a valid form for the INTERFACE statement. If + it does, implement the statement. */ + +static ffelexHandler +ffestb_R12022_ (ffelexToken t) +{ + ffesta_tokens[2] = ffelex_token_use (t); + + switch (ffelex_token_type (t)) + { + case FFELEX_typePERIOD: + if (ffestb_local_.interface.slash) + break; + return (ffelexHandler) ffestb_R12023_; + + case FFELEX_typePOWER: + if (ffestb_local_.interface.slash) + break; + ffestb_local_.interface.operator = FFESTP_definedoperatorPOWER; + return (ffelexHandler) ffestb_R12025_; + + case FFELEX_typeASTERISK: + if (ffestb_local_.interface.slash) + break; + ffestb_local_.interface.operator = FFESTP_definedoperatorMULT; + return (ffelexHandler) ffestb_R12025_; + + case FFELEX_typePLUS: + if (ffestb_local_.interface.slash) + break; + ffestb_local_.interface.operator = FFESTP_definedoperatorADD; + return (ffelexHandler) ffestb_R12025_; + + case FFELEX_typeCONCAT: + if (ffestb_local_.interface.slash) + break; + ffestb_local_.interface.operator = FFESTP_definedoperatorCONCAT; + return (ffelexHandler) ffestb_R12025_; + + case FFELEX_typeSLASH: + if (ffestb_local_.interface.slash) + { + ffestb_local_.interface.operator = FFESTP_definedoperatorCONCAT; + return (ffelexHandler) ffestb_R12025_; + } + ffestb_local_.interface.operator = FFESTP_definedoperatorDIVIDE; + return (ffelexHandler) ffestb_R12025_; + + case FFELEX_typeMINUS: + if (ffestb_local_.interface.slash) + break; + ffestb_local_.interface.operator = FFESTP_definedoperatorSUBTRACT; + return (ffelexHandler) ffestb_R12025_; + + case FFELEX_typeREL_EQ: + if (ffestb_local_.interface.slash) + break; + ffestb_local_.interface.operator = FFESTP_definedoperatorEQ; + return (ffelexHandler) ffestb_R12025_; + + case FFELEX_typeREL_NE: + if (ffestb_local_.interface.slash) + break; + ffestb_local_.interface.operator = FFESTP_definedoperatorNE; + return (ffelexHandler) ffestb_R12025_; + + case FFELEX_typeOPEN_ANGLE: + if (ffestb_local_.interface.slash) + break; + ffestb_local_.interface.operator = FFESTP_definedoperatorLT; + return (ffelexHandler) ffestb_R12025_; + + case FFELEX_typeREL_LE: + if (ffestb_local_.interface.slash) + break; + ffestb_local_.interface.operator = FFESTP_definedoperatorLE; + return (ffelexHandler) ffestb_R12025_; + + case FFELEX_typeCLOSE_ANGLE: + if (ffestb_local_.interface.slash) + break; + ffestb_local_.interface.operator = FFESTP_definedoperatorGT; + return (ffelexHandler) ffestb_R12025_; + + case FFELEX_typeREL_GE: + if (ffestb_local_.interface.slash) + break; + ffestb_local_.interface.operator = FFESTP_definedoperatorGE; + return (ffelexHandler) ffestb_R12025_; + + case FFELEX_typeEQUALS: + if (ffestb_local_.interface.slash) + { + ffestb_local_.interface.operator = FFESTP_definedoperatorNE; + return (ffelexHandler) ffestb_R12025_; + } + ffestb_local_.interface.operator = FFESTP_definedoperatorASSIGNMENT; + return (ffelexHandler) ffestb_R12025_; + + case FFELEX_typeCLOSE_ARRAY: + if (!ffestb_local_.interface.slash) + { + ffestb_local_.interface.operator = FFESTP_definedoperatorDIVIDE; + return (ffelexHandler) ffestb_R12026_; + } + ffestb_local_.interface.operator = FFESTP_definedoperatorCONCAT; + return (ffelexHandler) ffestb_R12026_; + + case FFELEX_typeCLOSE_PAREN: + if (!ffestb_local_.interface.slash) + break; + ffestb_local_.interface.operator = FFESTP_definedoperatorDIVIDE; + return (ffelexHandler) ffestb_R12026_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INTERFACE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R12023_ -- "INTERFACE" NAME OPEN_PAREN PERIOD + + return ffestb_R12023_; // to lexer + + Make sure the statement has a valid form for the INTERFACE statement. If + it does, implement the statement. */ + +static ffelexHandler +ffestb_R12023_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffelex_token_kill (ffesta_tokens[2]); + ffesta_tokens[2] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R12024_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INTERFACE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R12024_ -- "INTERFACE" NAME OPEN_PAREN PERIOD NAME + + return ffestb_R12024_; // to lexer + + Make sure the statement has a valid form for the INTERFACE statement. If + it does, implement the statement. */ + +static ffelexHandler +ffestb_R12024_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typePERIOD: + return (ffelexHandler) ffestb_R12025_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INTERFACE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R12025_ -- "INTERFACE" NAME OPEN_PAREN operator + + return ffestb_R12025_; // to lexer + + Make sure the statement has a valid form for the INTERFACE statement. If + it does, implement the statement. */ + +static ffelexHandler +ffestb_R12025_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + return (ffelexHandler) ffestb_R12026_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INTERFACE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R12026_ -- "INTERFACE" NAME OPEN_PAREN operator CLOSE_PAREN + + return ffestb_R12026_; // to lexer + + Make sure the statement has a valid form for the INTERFACE statement. If + it does, implement the statement. */ + +static ffelexHandler +ffestb_R12026_ (ffelexToken t) +{ + char *p; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (ffestb_local_.interface.assignment + && (ffestb_local_.interface.operator + != FFESTP_definedoperatorASSIGNMENT)) + { + ffebad_start (FFEBAD_INTERFACE_ASSIGNMENT); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[1]), + ffelex_token_where_column (ffesta_tokens[1])); + ffebad_here (1, ffelex_token_where_line (ffesta_tokens[2]), + ffelex_token_where_column (ffesta_tokens[2])); + ffebad_finish (); + } + switch (ffelex_token_type (ffesta_tokens[2])) + { + case FFELEX_typeNAME: + switch (ffestr_other (ffesta_tokens[2])) + { + case FFESTR_otherNOT: + if (!ffesta_is_inhibited ()) + ffestc_R1202 (FFESTP_definedoperatorNOT, NULL); + break; + + case FFESTR_otherAND: + if (!ffesta_is_inhibited ()) + ffestc_R1202 (FFESTP_definedoperatorAND, NULL); + break; + + case FFESTR_otherOR: + if (!ffesta_is_inhibited ()) + ffestc_R1202 (FFESTP_definedoperatorOR, NULL); + break; + + case FFESTR_otherEQV: + if (!ffesta_is_inhibited ()) + ffestc_R1202 (FFESTP_definedoperatorEQV, NULL); + break; + + case FFESTR_otherNEQV: + if (!ffesta_is_inhibited ()) + ffestc_R1202 (FFESTP_definedoperatorNEQV, NULL); + break; + + case FFESTR_otherEQ: + if (!ffesta_is_inhibited ()) + ffestc_R1202 (FFESTP_definedoperatorEQ, NULL); + break; + + case FFESTR_otherNE: + if (!ffesta_is_inhibited ()) + ffestc_R1202 (FFESTP_definedoperatorNE, NULL); + break; + + case FFESTR_otherLT: + if (!ffesta_is_inhibited ()) + ffestc_R1202 (FFESTP_definedoperatorLT, NULL); + break; + + case FFESTR_otherLE: + if (!ffesta_is_inhibited ()) + ffestc_R1202 (FFESTP_definedoperatorLE, NULL); + break; + + case FFESTR_otherGT: + if (!ffesta_is_inhibited ()) + ffestc_R1202 (FFESTP_definedoperatorGT, NULL); + break; + + case FFESTR_otherGE: + if (!ffesta_is_inhibited ()) + ffestc_R1202 (FFESTP_definedoperatorGE, NULL); + break; + + default: + for (p = ffelex_token_text (ffesta_tokens[2]); *p != '\0'; ++p) + { + if (!isalpha (*p)) + { + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffesta_ffebad_1t (FFEBAD_INTERFACE_NONLETTER, + ffesta_tokens[2]); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + } + } + if (!ffesta_is_inhibited ()) + ffestc_R1202 (FFESTP_definedoperatorOPERATOR, + ffesta_tokens[2]); + } + break; + + case FFELEX_typeEQUALS: + if (!ffestb_local_.interface.assignment + && (ffestb_local_.interface.operator + == FFESTP_definedoperatorASSIGNMENT)) + { + ffebad_start (FFEBAD_INTERFACE_OPERATOR); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[1]), + ffelex_token_where_column (ffesta_tokens[1])); + ffebad_here (1, ffelex_token_where_line (ffesta_tokens[2]), + ffelex_token_where_column (ffesta_tokens[2])); + ffebad_finish (); + } + if (!ffesta_is_inhibited ()) + ffestc_R1202 (ffestb_local_.interface.operator, NULL); + break; + + default: + if (!ffesta_is_inhibited ()) + ffestc_R1202 (ffestb_local_.interface.operator, NULL); + } + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INTERFACE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_S3P4 -- Parse the INCLUDE line + + return ffestb_S3P4; // to lexer + + Make sure the statement has a valid form for the INCLUDE line. If it + does, implement the statement. */ + +ffelexHandler +ffestb_S3P4 (ffelexToken t) +{ + ffeTokenLength i; + char *p; + ffelexHandler next; + ffelexToken nt; + ffelexToken ut; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstINCLUDE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + case FFELEX_typeAPOSTROPHE: + case FFELEX_typeQUOTE: + break; + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + ffesta_confirmed (); + return (ffelexHandler) (*((ffelexHandler) + ffeexpr_rhs (ffesta_output_pool, FFEEXPR_contextINCLUDE, + (ffeexprCallback) ffestb_S3P41_))) + (t); + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstINCLUDE) + goto bad_0; /* :::::::::::::::::::: */ + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlINCLUDE); + switch (ffelex_token_type (t)) + { + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeAPOSTROPHE: + case FFELEX_typeQUOTE: + break; + } + ffesta_confirmed (); + if (*p == '\0') + return (ffelexHandler) (*((ffelexHandler) + ffeexpr_rhs (ffesta_output_pool, FFEEXPR_contextINCLUDE, + (ffeexprCallback) ffestb_S3P41_))) + (t); + if (!isdigit (*p)) + goto bad_i; /* :::::::::::::::::::: */ + nt = ffelex_token_number_from_names (ffesta_tokens[0], i); + p += ffelex_token_length (nt); + i += ffelex_token_length (nt); + if ((*p != '_') || (++i, *++p != '\0')) + { + ffelex_token_kill (nt); + goto bad_i; /* :::::::::::::::::::: */ + } + ut = ffelex_token_uscore_from_names (ffesta_tokens[0], i - 1); + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs + (ffesta_output_pool, FFEEXPR_contextINCLUDE, + (ffeexprCallback) ffestb_S3P41_))) + (nt); + ffelex_token_kill (nt); + next = (ffelexHandler) (*next) (ut); + ffelex_token_kill (ut); + return (ffelexHandler) (*next) (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INCLUDE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INCLUDE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "INCLUDE", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_S3P41_ -- "INCLUDE" [NUMBER "_"] expr + + (ffestb_S3P41_) // to expression handler + + Make sure the next token is an EOS, but not a SEMICOLON. */ + +static ffelexHandler +ffestb_S3P41_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + { + if (ffe_is_pedantic () + && ((ffelex_token_type (t) == FFELEX_typeSEMICOLON) + || ffesta_line_has_semicolons)) + { + ffebad_start_msg ("INCLUDE at %0 not the only statement on the source line", FFEBAD_severityWARNING); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + } + ffestc_S3P4 (expr, ft); + } + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INCLUDE", t); + break; + } + + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V012 -- Parse the MAP statement + + return ffestb_V012; // to lexer + + Make sure the statement has a valid form for the MAP statement. If + it does, implement the statement. */ + +#if FFESTR_VXT +ffelexHandler +ffestb_V012 (ffelexToken t) +{ + char *p; + ffeTokenLength i; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstMAP) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstMAP) + goto bad_0; /* :::::::::::::::::::: */ + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlMAP) + { + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlMAP); + goto bad_i; /* :::::::::::::::::::: */ + } + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_V012 (); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "MAP", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid first token. */ + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "MAP", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "MAP", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_V014 -- Parse the VOLATILE statement + + return ffestb_V014; // to lexer + + Make sure the statement has a valid form for the VOLATILE statement. If it + does, implement the statement. */ + +ffelexHandler +ffestb_V014 (ffelexToken t) +{ + ffeTokenLength i; + char *p; + ffelexToken nt; + ffelexHandler next; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstVOLATILE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + case FFELEX_typeSLASH: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_V014_start (); + return (ffelexHandler) ffestb_V0141_ (t); + + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_V014_start (); + return (ffelexHandler) ffestb_V0141_; + } + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstVOLATILE) + goto bad_0; /* :::::::::::::::::::: */ + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlVOLATILE); + switch (ffelex_token_type (t)) + { + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeCOMMA: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + break; + + case FFELEX_typeSLASH: + ffesta_confirmed (); + if (*p != '\0') + goto bad_i; /* :::::::::::::::::::: */ + if (!ffesta_is_inhibited ()) + ffestc_V014_start (); + return (ffelexHandler) ffestb_V0141_ (t); + + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); + if (*p != '\0') + goto bad_i; /* :::::::::::::::::::: */ + if (!ffesta_is_inhibited ()) + ffestc_V014_start (); + return (ffelexHandler) ffestb_V0141_; + } + + /* Here, we have at least one char after "VOLATILE" and t is COMMA or + EOS/SEMICOLON. */ + + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + if (!ffesta_is_inhibited ()) + ffestc_V014_start (); + next = (ffelexHandler) ffestb_V0141_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "VOLATILE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "VOLATILE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "VOLATILE", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0141_ -- "VOLATILE" [COLONCOLON] + + return ffestb_V0141_; // to lexer + + Handle NAME or SLASH. */ + +static ffelexHandler +ffestb_V0141_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffestb_local_.V014.is_cblock = FALSE; + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_V0144_; + + case FFELEX_typeSLASH: + ffestb_local_.V014.is_cblock = TRUE; + return (ffelexHandler) ffestb_V0142_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "VOLATILE", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_V014_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0142_ -- "VOLATILE" [COLONCOLON] SLASH + + return ffestb_V0142_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_V0142_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_V0143_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "VOLATILE", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_V014_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0143_ -- "VOLATILE" [COLONCOLON] SLASH NAME + + return ffestb_V0143_; // to lexer + + Handle SLASH. */ + +static ffelexHandler +ffestb_V0143_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeSLASH: + return (ffelexHandler) ffestb_V0144_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "VOLATILE", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_V014_finish (); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0144_ -- "VOLATILE" [COLONCOLON] R523 + + return ffestb_V0144_; // to lexer + + Handle COMMA or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_V0144_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (!ffesta_is_inhibited ()) + { + if (ffestb_local_.V014.is_cblock) + ffestc_V014_item_cblock (ffesta_tokens[1]); + else + ffestc_V014_item_object (ffesta_tokens[1]); + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_V0141_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + { + if (ffestb_local_.V014.is_cblock) + ffestc_V014_item_cblock (ffesta_tokens[1]); + else + ffestc_V014_item_object (ffesta_tokens[1]); + ffestc_V014_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "VOLATILE", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_V014_finish (); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V025 -- Parse the DEFINEFILE statement + + return ffestb_V025; // to lexer + + Make sure the statement has a valid form for the DEFINEFILE statement. + If it does, implement the statement. */ + +#if FFESTR_VXT +ffelexHandler +ffestb_V025 (ffelexToken t) +{ + ffeTokenLength i; + char *p; + ffelexToken nt; + ffelexHandler next; + + ffestb_local_.V025.started = FALSE; + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + switch (ffesta_first_kw) + { + case FFESTR_firstDEFINE: + if ((ffelex_token_type (t) != FFELEX_typeNAME) + || (ffesta_second_kw != FFESTR_secondFILE)) + goto bad_1; /* :::::::::::::::::::: */ + ffesta_confirmed (); + return (ffelexHandler) ffestb_V0251_; + + case FFESTR_firstDEFINEFILE: + return (ffelexHandler) ffestb_V0251_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstDEFINEFILE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + break; + } + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlDEFINEFILE); + if (isdigit (*p)) + nt = ffelex_token_number_from_names (ffesta_tokens[0], i); + else if (ffesrc_is_name_init (*p)) + nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + else + goto bad_i; /* :::::::::::::::::::: */ + next = (ffelexHandler) ffestb_V0251_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0251_ -- "DEFINEFILE" or "DEFINE" "FILE" + + return ffestb_V0251_; // to lexer + + Make sure the statement has a valid form for the DEFINEFILE statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_V0251_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + case FFELEX_typeNUMBER: + if (ffelex_token_type (ffesta_tokens[0]) == FFELEX_typeNAME) + ffesta_confirmed (); + return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEUNIT_DF, (ffeexprCallback) ffestb_V0252_))) + (t); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + break; + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0252_ -- "DEFINEFILE" expr + + (ffestb_V0252_) // to expression handler + + Make sure the statement has a valid form for the DEFINEFILE statement. If + it does, implement the statement. */ + +static ffelexHandler +ffestb_V0252_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + ffestb_local_.V025.u = expr; + ffesta_tokens[1] = ffelex_token_use (ft); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_V0253_); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0253_ -- "DEFINEFILE" expr OPEN_PAREN expr + + (ffestb_V0253_) // to expression handler + + Make sure the statement has a valid form for the DEFINEFILE statement. If + it does, implement the statement. */ + +static ffelexHandler +ffestb_V0253_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffestb_local_.V025.m = expr; + ffesta_tokens[2] = ffelex_token_use (ft); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_V0254_); + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0254_ -- "DEFINEFILE" expr OPEN_PAREN expr COMMA expr + + (ffestb_V0254_) // to expression handler + + Make sure the statement has a valid form for the DEFINEFILE statement. If + it does, implement the statement. */ + +static ffelexHandler +ffestb_V0254_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffestb_local_.V025.n = expr; + ffesta_tokens[3] = ffelex_token_use (ft); + return (ffelexHandler) ffestb_V0255_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0255_ -- "DEFINEFILE" expr OPEN_PAREN expr COMMA expr COMMA + + return ffestb_V0255_; // to lexer + + Make sure the statement has a valid form for the DEFINEFILE statement. If + it does, implement the statement. */ + +static ffelexHandler +ffestb_V0255_ (ffelexToken t) +{ + char *p; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + p = ffelex_token_text (t); + if (!ffesrc_char_match_init (*p, 'U', 'u') || (*++p != '\0')) + break; + return (ffelexHandler) ffestb_V0256_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffelex_token_kill (ffesta_tokens[3]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0256_ -- "DEFINEFILE" expr OPEN_PAREN expr COMMA expr COMMA "U" + + return ffestb_V0256_; // to lexer + + Make sure the statement has a valid form for the DEFINEFILE statement. If + it does, implement the statement. */ + +static ffelexHandler +ffestb_V0256_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextFILEASSOC, + (ffeexprCallback) ffestb_V0257_); + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffelex_token_kill (ffesta_tokens[3]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0257_ -- "DEFINEFILE" expr OPEN_PAREN expr COMMA expr COMMA "U" + COMMA expr + + (ffestb_V0257_) // to expression handler + + Make sure the statement has a valid form for the DEFINEFILE statement. If + it does, implement the statement. */ + +static ffelexHandler +ffestb_V0257_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + ffestb_local_.V025.asv = expr; + ffesta_tokens[4] = ffelex_token_use (ft); + return (ffelexHandler) ffestb_V0258_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffelex_token_kill (ffesta_tokens[3]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0258_ -- "DEFINEFILE" expr OPEN_PAREN expr COMMA expr COMMA "U" + COMMA expr CLOSE_PAREN + + return ffestb_V0258_; // to lexer + + Make sure the statement has a valid form for the DEFINEFILE statement. If + it does, implement the statement. */ + +static ffelexHandler +ffestb_V0258_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffestb_local_.V025.started) + { + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_V025_start (); + ffestb_local_.V025.started = TRUE; + } + if (!ffesta_is_inhibited ()) + ffestc_V025_item (ffestb_local_.V025.u, ffesta_tokens[1], + ffestb_local_.V025.m, ffesta_tokens[2], + ffestb_local_.V025.n, ffesta_tokens[3], + ffestb_local_.V025.asv, ffesta_tokens[4]); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffelex_token_kill (ffesta_tokens[3]); + ffelex_token_kill (ffesta_tokens[4]); + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEUNIT_DF, (ffeexprCallback) ffestb_V0252_); + if (!ffesta_is_inhibited ()) + ffestc_V025_finish (); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffelex_token_kill (ffesta_tokens[3]); + ffelex_token_kill (ffesta_tokens[4]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DEFINE FILE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_subr_kill_easy_ -- Kill I/O statement data structure + + ffestb_subr_kill_easy_(); + + Kills all tokens in the I/O data structure. Assumes that they are + overlaid with each other (union) in ffest_private.h and the typing + and structure references assume (though not necessarily dangerous if + FALSE) that INQUIRE has the most file elements. */ + +#if FFESTB_KILL_EASY_ +static void +ffestb_subr_kill_easy_ (ffestpInquireIx max) +{ + ffestpInquireIx ix; + + for (ix = 0; ix < max; ++ix) + { + if (ffestp_file.inquire.inquire_spec[ix].kw_or_val_present) + { + if (ffestp_file.inquire.inquire_spec[ix].kw_present) + ffelex_token_kill (ffestp_file.inquire.inquire_spec[ix].kw); + if (ffestp_file.inquire.inquire_spec[ix].value_present) + ffelex_token_kill (ffestp_file.inquire.inquire_spec[ix].value); + } + } +} + +#endif +/* ffestb_subr_kill_accept_ -- Kill ACCEPT statement data structure + + ffestb_subr_kill_accept_(); + + Kills all tokens in the ACCEPT data structure. */ + +#if !FFESTB_KILL_EASY_ +static void +ffestb_subr_kill_accept_ () +{ + ffestpAcceptIx ix; + + for (ix = 0; ix < FFESTP_acceptix; ++ix) + { + if (ffestp_file.accept.accept_spec[ix].kw_or_val_present) + { + if (ffestp_file.accept.accept_spec[ix].kw_present) + ffelex_token_kill (ffestp_file.accept.accept_spec[ix].kw); + if (ffestp_file.accept.accept_spec[ix].value_present) + ffelex_token_kill (ffestp_file.accept.accept_spec[ix].value); + } + } +} + +#endif +/* ffestb_subr_kill_beru_ -- Kill BACKSPACE/ENDFILE/REWIND/UNLOCK statement + data structure + + ffestb_subr_kill_beru_(); + + Kills all tokens in the BACKSPACE/ENDFILE/REWIND/UNLOCK data structure. */ + +#if !FFESTB_KILL_EASY_ +static void +ffestb_subr_kill_beru_ () +{ + ffestpBeruIx ix; + + for (ix = 0; ix < FFESTP_beruix; ++ix) + { + if (ffestp_file.beru.beru_spec[ix].kw_or_val_present) + { + if (ffestp_file.beru.beru_spec[ix].kw_present) + ffelex_token_kill (ffestp_file.beru.beru_spec[ix].kw); + if (ffestp_file.beru.beru_spec[ix].value_present) + ffelex_token_kill (ffestp_file.beru.beru_spec[ix].value); + } + } +} + +#endif +/* ffestb_subr_kill_close_ -- Kill CLOSE statement data structure + + ffestb_subr_kill_close_(); + + Kills all tokens in the CLOSE data structure. */ + +#if !FFESTB_KILL_EASY_ +static void +ffestb_subr_kill_close_ () +{ + ffestpCloseIx ix; + + for (ix = 0; ix < FFESTP_closeix; ++ix) + { + if (ffestp_file.close.close_spec[ix].kw_or_val_present) + { + if (ffestp_file.close.close_spec[ix].kw_present) + ffelex_token_kill (ffestp_file.close.close_spec[ix].kw); + if (ffestp_file.close.close_spec[ix].value_present) + ffelex_token_kill (ffestp_file.close.close_spec[ix].value); + } + } +} + +#endif +/* ffestb_subr_kill_delete_ -- Kill DELETE statement data structure + + ffestb_subr_kill_delete_(); + + Kills all tokens in the DELETE data structure. */ + +#if !FFESTB_KILL_EASY_ +static void +ffestb_subr_kill_delete_ () +{ + ffestpDeleteIx ix; + + for (ix = 0; ix < FFESTP_deleteix; ++ix) + { + if (ffestp_file.delete.delete_spec[ix].kw_or_val_present) + { + if (ffestp_file.delete.delete_spec[ix].kw_present) + ffelex_token_kill (ffestp_file.delete.delete_spec[ix].kw); + if (ffestp_file.delete.delete_spec[ix].value_present) + ffelex_token_kill (ffestp_file.delete.delete_spec[ix].value); + } + } +} + +#endif +/* ffestb_subr_kill_inquire_ -- Kill INQUIRE statement data structure + + ffestb_subr_kill_inquire_(); + + Kills all tokens in the INQUIRE data structure. */ + +#if !FFESTB_KILL_EASY_ +static void +ffestb_subr_kill_inquire_ () +{ + ffestpInquireIx ix; + + for (ix = 0; ix < FFESTP_inquireix; ++ix) + { + if (ffestp_file.inquire.inquire_spec[ix].kw_or_val_present) + { + if (ffestp_file.inquire.inquire_spec[ix].kw_present) + ffelex_token_kill (ffestp_file.inquire.inquire_spec[ix].kw); + if (ffestp_file.inquire.inquire_spec[ix].value_present) + ffelex_token_kill (ffestp_file.inquire.inquire_spec[ix].value); + } + } +} + +#endif +/* ffestb_subr_kill_open_ -- Kill OPEN statement data structure + + ffestb_subr_kill_open_(); + + Kills all tokens in the OPEN data structure. */ + +#if !FFESTB_KILL_EASY_ +static void +ffestb_subr_kill_open_ () +{ + ffestpOpenIx ix; + + for (ix = 0; ix < FFESTP_openix; ++ix) + { + if (ffestp_file.open.open_spec[ix].kw_or_val_present) + { + if (ffestp_file.open.open_spec[ix].kw_present) + ffelex_token_kill (ffestp_file.open.open_spec[ix].kw); + if (ffestp_file.open.open_spec[ix].value_present) + ffelex_token_kill (ffestp_file.open.open_spec[ix].value); + } + } +} + +#endif +/* ffestb_subr_kill_print_ -- Kill PRINT statement data structure + + ffestb_subr_kill_print_(); + + Kills all tokens in the PRINT data structure. */ + +#if !FFESTB_KILL_EASY_ +static void +ffestb_subr_kill_print_ () +{ + ffestpPrintIx ix; + + for (ix = 0; ix < FFESTP_printix; ++ix) + { + if (ffestp_file.print.print_spec[ix].kw_or_val_present) + { + if (ffestp_file.print.print_spec[ix].kw_present) + ffelex_token_kill (ffestp_file.print.print_spec[ix].kw); + if (ffestp_file.print.print_spec[ix].value_present) + ffelex_token_kill (ffestp_file.print.print_spec[ix].value); + } + } +} + +#endif +/* ffestb_subr_kill_read_ -- Kill READ statement data structure + + ffestb_subr_kill_read_(); + + Kills all tokens in the READ data structure. */ + +#if !FFESTB_KILL_EASY_ +static void +ffestb_subr_kill_read_ () +{ + ffestpReadIx ix; + + for (ix = 0; ix < FFESTP_readix; ++ix) + { + if (ffestp_file.read.read_spec[ix].kw_or_val_present) + { + if (ffestp_file.read.read_spec[ix].kw_present) + ffelex_token_kill (ffestp_file.read.read_spec[ix].kw); + if (ffestp_file.read.read_spec[ix].value_present) + ffelex_token_kill (ffestp_file.read.read_spec[ix].value); + } + } +} + +#endif +/* ffestb_subr_kill_rewrite_ -- Kill REWRITE statement data structure + + ffestb_subr_kill_rewrite_(); + + Kills all tokens in the REWRITE data structure. */ + +#if !FFESTB_KILL_EASY_ +static void +ffestb_subr_kill_rewrite_ () +{ + ffestpRewriteIx ix; + + for (ix = 0; ix < FFESTP_rewriteix; ++ix) + { + if (ffestp_file.rewrite.rewrite_spec[ix].kw_or_val_present) + { + if (ffestp_file.rewrite.rewrite_spec[ix].kw_present) + ffelex_token_kill (ffestp_file.rewrite.rewrite_spec[ix].kw); + if (ffestp_file.rewrite.rewrite_spec[ix].value_present) + ffelex_token_kill (ffestp_file.rewrite.rewrite_spec[ix].value); + } + } +} + +#endif +/* ffestb_subr_kill_type_ -- Kill TYPE statement data structure + + ffestb_subr_kill_type_(); + + Kills all tokens in the TYPE data structure. */ + +#if !FFESTB_KILL_EASY_ +static void +ffestb_subr_kill_type_ () +{ + ffestpTypeIx ix; + + for (ix = 0; ix < FFESTP_typeix; ++ix) + { + if (ffestp_file.type.type_spec[ix].kw_or_val_present) + { + if (ffestp_file.type.type_spec[ix].kw_present) + ffelex_token_kill (ffestp_file.type.type_spec[ix].kw); + if (ffestp_file.type.type_spec[ix].value_present) + ffelex_token_kill (ffestp_file.type.type_spec[ix].value); + } + } +} + +#endif +/* ffestb_subr_kill_write_ -- Kill WRITE statement data structure + + ffestb_subr_kill_write_(); + + Kills all tokens in the WRITE data structure. */ + +#if !FFESTB_KILL_EASY_ +static void +ffestb_subr_kill_write_ () +{ + ffestpWriteIx ix; + + for (ix = 0; ix < FFESTP_writeix; ++ix) + { + if (ffestp_file.write.write_spec[ix].kw_or_val_present) + { + if (ffestp_file.write.write_spec[ix].kw_present) + ffelex_token_kill (ffestp_file.write.write_spec[ix].kw); + if (ffestp_file.write.write_spec[ix].value_present) + ffelex_token_kill (ffestp_file.write.write_spec[ix].value); + } + } +} + +#endif +/* ffestb_beru -- Parse the BACKSPACE/ENDFILE/REWIND/UNLOCK statement + + return ffestb_beru; // to lexer + + Make sure the statement has a valid form for the BACKSPACE/ENDFILE/REWIND/ + UNLOCK statement. If it does, implement the statement. */ + +ffelexHandler +ffestb_beru (ffelexToken t) +{ + ffelexHandler next; + ffestpBeruIx ix; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + case FFELEX_typeCOLON: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + case FFELEX_typeNUMBER: + ffesta_confirmed (); + break; + + case FFELEX_typeOPEN_PAREN: + for (ix = 0; ix < FFESTP_beruix; ++ix) + ffestp_file.beru.beru_spec[ix].kw_or_val_present = FALSE; + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_beru2_; + + default: + break; + } + + for (ix = 0; ix < FFESTP_beruix; ++ix) + ffestp_file.beru.beru_spec[ix].kw_or_val_present = FALSE; + return (ffelexHandler) (*((ffelexHandler) + ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUM, + (ffeexprCallback) ffestb_beru1_))) + (t); + + case FFELEX_typeNAMES: + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + case FFELEX_typeCOLON: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + break; + + case FFELEX_typeOPEN_PAREN: + if (ffelex_token_length (ffesta_tokens[0]) + != ffestb_args.beru.len) + break; + + for (ix = 0; ix < FFESTP_beruix; ++ix) + ffestp_file.beru.beru_spec[ix].kw_or_val_present = FALSE; + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_beru2_; + + default: + break; + } + for (ix = 0; ix < FFESTP_beruix; ++ix) + ffestp_file.beru.beru_spec[ix].kw_or_val_present = FALSE; + next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_beru1_); + next = (ffelexHandler) ffelex_splice_tokens (next, ffesta_tokens[0], + ffestb_args.beru.len); + if (next == NULL) + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + return (ffelexHandler) (*next) (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_beru1_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" expr + + (ffestb_beru1_) // to expression handler + + Make sure the next token is an EOS or SEMICOLON. */ + +static ffelexHandler +ffestb_beru1_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (expr == NULL) + break; + ffesta_confirmed (); + ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].kw_or_val_present + = TRUE; + ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].kw_present = FALSE; + ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].value_present = TRUE; + ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].value_is_label + = FALSE; + ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].value + = ffelex_token_use (ft); + ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].u.expr = expr; + if (!ffesta_is_inhibited ()) + { + switch (ffesta_first_kw) + { + case FFESTR_firstBACKSPACE: + ffestc_R919 (); + break; + + case FFESTR_firstENDFILE: + case FFESTR_firstEND: + ffestc_R920 (); + break; + + case FFESTR_firstREWIND: + ffestc_R921 (); + break; + +#if FFESTR_VXT + case FFESTR_firstUNLOCK: + ffestc_V022 (); + break; +#endif + + default: + assert (FALSE); + } + } + ffestb_subr_kill_beru_ (); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffestb_subr_kill_beru_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_beru2_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN + + return ffestb_beru2_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_beru2_ (ffelexToken t) +{ + ffelexToken nt; + ffelexHandler next; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[2] = ffelex_token_use (t); + return (ffelexHandler) ffestb_beru3_; + + default: + nt = ffesta_tokens[1]; + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUMAMBIG, (ffeexprCallback) ffestb_beru4_))) + (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + } +} + +/* ffestb_beru3_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN NAME + + return ffestb_beru3_; // to lexer + + If EQUALS here, go to states that handle it. Else, send NAME and this + token thru expression handler. */ + +static ffelexHandler +ffestb_beru3_ (ffelexToken t) +{ + ffelexHandler next; + ffelexToken nt; + ffelexToken ot; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + ffelex_token_kill (ffesta_tokens[1]); + nt = ffesta_tokens[2]; + next = (ffelexHandler) ffestb_beru5_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + nt = ffesta_tokens[1]; + ot = ffesta_tokens[2]; + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUMAMBIG, (ffeexprCallback) ffestb_beru4_))) + (nt); + ffelex_token_kill (nt); + next = (ffelexHandler) (*next) (ot); + ffelex_token_kill (ot); + return (ffelexHandler) (*next) (t); + } +} + +/* ffestb_beru4_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN expr [CLOSE_PAREN] + + (ffestb_beru4_) // to expression handler + + Handle COMMA or EOS/SEMICOLON here. + + 15-Feb-91 JCB 1.2 + Now using new mechanism whereby expr comes back as opITEM if the + expr is considered part (or all) of an I/O control list (and should + be stripped of its outer opITEM node) or not if it is considered + a plain unit number that happens to have been enclosed in parens. + 26-Mar-90 JCB 1.1 + No longer expecting close-paren here because of constructs like + BACKSPACE (5)+2, so now expecting either COMMA because it was a + construct like BACKSPACE (5+2,... or EOS/SEMICOLON because it is like + the former construct. Ah, the vagaries of Fortran. */ + +static ffelexHandler +ffestb_beru4_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + bool inlist; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + if (ffebld_op (expr) == FFEBLD_opITEM) + { + inlist = TRUE; + expr = ffebld_head (expr); + } + else + inlist = FALSE; + ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].kw_or_val_present + = TRUE; + ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].kw_present = FALSE; + ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].value_present = TRUE; + ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].value_is_label + = FALSE; + ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].value + = ffelex_token_use (ft); + ffestp_file.beru.beru_spec[FFESTP_beruixUNIT].u.expr = expr; + if (inlist) + return (ffelexHandler) ffestb_beru9_ (t); + return (ffelexHandler) ffestb_beru10_ (t); + + default: + break; + } + + ffestb_subr_kill_beru_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_beru5_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN [external-file-unit + COMMA] + + return ffestb_beru5_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_beru5_ (ffelexToken t) +{ + ffestrGenio kw; + + ffestb_local_.beru.label = FALSE; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + kw = ffestr_genio (t); + switch (kw) + { + case FFESTR_genioERR: + ffestb_local_.beru.ix = FFESTP_beruixERR; + ffestb_local_.beru.label = TRUE; + break; + + case FFESTR_genioIOSTAT: + ffestb_local_.beru.ix = FFESTP_beruixIOSTAT; + ffestb_local_.beru.left = TRUE; + ffestb_local_.beru.context = FFEEXPR_contextFILEINT; + break; + + case FFESTR_genioUNIT: + ffestb_local_.beru.ix = FFESTP_beruixUNIT; + ffestb_local_.beru.left = FALSE; + ffestb_local_.beru.context = FFEEXPR_contextFILENUM; + break; + + default: + goto bad; /* :::::::::::::::::::: */ + } + if (ffestp_file.beru.beru_spec[ffestb_local_.beru.ix] + .kw_or_val_present) + break; /* Can't specify a keyword twice! */ + ffestp_file.beru.beru_spec[ffestb_local_.beru.ix] + .kw_or_val_present = TRUE; + ffestp_file.beru.beru_spec[ffestb_local_.beru.ix] + .kw_present = TRUE; + ffestp_file.beru.beru_spec[ffestb_local_.beru.ix] + .value_present = FALSE; + ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].value_is_label + = ffestb_local_.beru.label; + ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].kw + = ffelex_token_use (t); + return (ffelexHandler) ffestb_beru6_; + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffestb_subr_kill_beru_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_beru6_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN [external-file-unit + COMMA] NAME + + return ffestb_beru6_; // to lexer + + Make sure EQUALS here, send next token to expression handler. */ + +static ffelexHandler +ffestb_beru6_ (ffelexToken t) +{ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + ffesta_confirmed (); + if (ffestb_local_.beru.label) + return (ffelexHandler) ffestb_beru8_; + if (ffestb_local_.beru.left) + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + ffestb_local_.beru.context, + (ffeexprCallback) ffestb_beru7_); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + ffestb_local_.beru.context, + (ffeexprCallback) ffestb_beru7_); + + default: + break; + } + + ffestb_subr_kill_beru_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_beru7_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN ... NAME EQUALS expr + + (ffestb_beru7_) // to expression handler + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_beru7_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].value_present + = TRUE; + ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].value + = ffelex_token_use (ft); + ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_beru5_; + return (ffelexHandler) ffestb_beru10_; + + default: + break; + } + + ffestb_subr_kill_beru_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_beru8_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN ... NAME EQUALS + + return ffestb_beru8_; // to lexer + + Handle NUMBER for label here. */ + +static ffelexHandler +ffestb_beru8_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].value_present + = TRUE; + ffestp_file.beru.beru_spec[ffestb_local_.beru.ix].value + = ffelex_token_use (t); + return (ffelexHandler) ffestb_beru9_; + + default: + break; + } + + ffestb_subr_kill_beru_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_beru9_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN ... NAME EQUALS + NUMBER + + return ffestb_beru9_; // to lexer + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_beru9_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_beru5_; + + case FFELEX_typeCLOSE_PAREN: + return (ffelexHandler) ffestb_beru10_; + + default: + break; + } + + ffestb_subr_kill_beru_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_beru10_ -- "BACKSPACE/ENDFILE/REWIND/UNLOCK" OPEN_PAREN ... CLOSE_PAREN + + return ffestb_beru10_; // to lexer + + Handle EOS or SEMICOLON here. */ + +static ffelexHandler +ffestb_beru10_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + switch (ffesta_first_kw) + { + case FFESTR_firstBACKSPACE: + ffestc_R919 (); + break; + + case FFESTR_firstENDFILE: + case FFESTR_firstEND: + ffestc_R920 (); + break; + + case FFESTR_firstREWIND: + ffestc_R921 (); + break; + +#if FFESTR_VXT + case FFESTR_firstUNLOCK: + ffestc_V022 (); + break; +#endif + + default: + assert (FALSE); + } + } + ffestb_subr_kill_beru_ (); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffestb_subr_kill_beru_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.beru.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_vxtcode -- Parse the VXT DECODE/ENCODE statement + + return ffestb_vxtcode; // to lexer + + Make sure the statement has a valid form for the VXT DECODE/ENCODE + statement. If it does, implement the statement. */ + +#if FFESTR_VXT +ffelexHandler +ffestb_vxtcode (ffelexToken t) +{ + ffestpVxtcodeIx ix; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeNAME: + case FFELEX_typeNUMBER: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + for (ix = 0; ix < FFESTP_vxtcodeix; ++ix) + ffestp_file.vxtcode.vxtcode_spec[ix].kw_or_val_present = FALSE; + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_vxtcode1_); + } + + case FFELEX_typeNAMES: + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + if (ffelex_token_length (ffesta_tokens[0]) + != ffestb_args.vxtcode.len) + goto bad_0; /* :::::::::::::::::::: */ + + for (ix = 0; ix < FFESTP_vxtcodeix; ++ix) + ffestp_file.vxtcode.vxtcode_spec[ix].kw_or_val_present = FALSE; + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_vxtcode1_); + } + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_vxtcode1_ -- "VXTCODE" OPEN_PAREN expr + + (ffestb_vxtcode1_) // to expression handler + + Handle COMMA here. */ + +static ffelexHandler +ffestb_vxtcode1_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixC].kw_or_val_present + = TRUE; + ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixC].kw_present = FALSE; + ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixC].value_present = TRUE; + ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixC].value_is_label + = FALSE; + ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixC].value + = ffelex_token_use (ft); + ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixC].u.expr = expr; + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEFORMAT, (ffeexprCallback) ffestb_vxtcode2_); + + default: + break; + } + + ffestb_subr_kill_vxtcode_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_vxtcode2_ -- "VXTCODE" OPEN_PAREN expr COMMA expr + + (ffestb_vxtcode2_) // to expression handler + + Handle COMMA here. */ + +static ffelexHandler +ffestb_vxtcode2_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixF].kw_or_val_present + = TRUE; + ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixF].kw_present = FALSE; + ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixF].value_present = TRUE; + ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixF].value_is_label + = (expr == NULL); + ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixF].value + = ffelex_token_use (ft); + ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixF].u.expr = expr; + if (ffesta_first_kw == FFESTR_firstENCODE) + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextFILEVXTCODE, + (ffeexprCallback) ffestb_vxtcode3_); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEVXTCODE, + (ffeexprCallback) ffestb_vxtcode3_); + + default: + break; + } + + ffestb_subr_kill_vxtcode_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_vxtcode3_ -- "VXTCODE" OPEN_PAREN expr COMMA expr COMMA expr + + (ffestb_vxtcode3_) // to expression handler + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_vxtcode3_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixB].kw_or_val_present + = TRUE; + ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixB].kw_present = FALSE; + ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixB].value_present = TRUE; + ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixB].value_is_label + = FALSE; + ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixB].value + = ffelex_token_use (ft); + ffestp_file.vxtcode.vxtcode_spec[FFESTP_vxtcodeixB].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_vxtcode4_; + return (ffelexHandler) ffestb_vxtcode9_; + + default: + break; + } + + ffestb_subr_kill_vxtcode_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_vxtcode4_ -- "VXTCODE" OPEN_PAREN ... + + return ffestb_vxtcode4_; // to lexer + + Handle NAME=expr construct here. */ + +static ffelexHandler +ffestb_vxtcode4_ (ffelexToken t) +{ + ffestrGenio kw; + + ffestb_local_.vxtcode.label = FALSE; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + kw = ffestr_genio (t); + switch (kw) + { + case FFESTR_genioERR: + ffestb_local_.vxtcode.ix = FFESTP_vxtcodeixERR; + ffestb_local_.vxtcode.label = TRUE; + break; + + case FFESTR_genioIOSTAT: + ffestb_local_.vxtcode.ix = FFESTP_vxtcodeixIOSTAT; + ffestb_local_.vxtcode.left = TRUE; + ffestb_local_.vxtcode.context = FFEEXPR_contextFILEINT; + break; + + default: + goto bad; /* :::::::::::::::::::: */ + } + if (ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix] + .kw_or_val_present) + break; /* Can't specify a keyword twice! */ + ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix] + .kw_or_val_present = TRUE; + ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix] + .kw_present = TRUE; + ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix] + .value_present = FALSE; + ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix].value_is_label + = ffestb_local_.vxtcode.label; + ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix].kw + = ffelex_token_use (t); + return (ffelexHandler) ffestb_vxtcode5_; + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffestb_subr_kill_vxtcode_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_vxtcode5_ -- "VXTCODE" OPEN_PAREN [external-file-unit COMMA [format + COMMA]] NAME + + return ffestb_vxtcode5_; // to lexer + + Make sure EQUALS here, send next token to expression handler. */ + +static ffelexHandler +ffestb_vxtcode5_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + ffesta_confirmed (); + if (ffestb_local_.vxtcode.label) + return (ffelexHandler) ffestb_vxtcode7_; + if (ffestb_local_.vxtcode.left) + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + ffestb_local_.vxtcode.context, + (ffeexprCallback) ffestb_vxtcode6_); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + ffestb_local_.vxtcode.context, + (ffeexprCallback) ffestb_vxtcode6_); + + default: + break; + } + + ffestb_subr_kill_vxtcode_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_vxtcode6_ -- "VXTCODE" OPEN_PAREN ... NAME EQUALS expr + + (ffestb_vxtcode6_) // to expression handler + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_vxtcode6_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix].value_present + = TRUE; + ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix].value + = ffelex_token_use (ft); + ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_vxtcode4_; + return (ffelexHandler) ffestb_vxtcode9_; + + default: + break; + } + + ffestb_subr_kill_vxtcode_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_vxtcode7_ -- "VXTCODE" OPEN_PAREN ... NAME EQUALS + + return ffestb_vxtcode7_; // to lexer + + Handle NUMBER for label here. */ + +static ffelexHandler +ffestb_vxtcode7_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix].value_present + = TRUE; + ffestp_file.vxtcode.vxtcode_spec[ffestb_local_.vxtcode.ix].value + = ffelex_token_use (t); + return (ffelexHandler) ffestb_vxtcode8_; + + default: + break; + } + + ffestb_subr_kill_vxtcode_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_vxtcode8_ -- "VXTCODE" OPEN_PAREN ... NAME EQUALS NUMBER + + return ffestb_vxtcode8_; // to lexer + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_vxtcode8_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_vxtcode4_; + + case FFELEX_typeCLOSE_PAREN: + return (ffelexHandler) ffestb_vxtcode9_; + + default: + break; + } + + ffestb_subr_kill_vxtcode_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_vxtcode9_ -- "VXTCODE" OPEN_PAREN ... CLOSE_PAREN + + return ffestb_vxtcode9_; // to lexer + + Handle EOS or SEMICOLON here. + + 07-Jun-90 JCB 1.1 + Context for ENCODE/DECODE expressions is now IOLISTDF instead of IOLIST + since they apply to internal files. */ + +static ffelexHandler +ffestb_vxtcode9_ (ffelexToken t) +{ + ffelexHandler next; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + if (ffesta_first_kw == FFESTR_firstENCODE) + { + ffestc_V023_start (); + ffestc_V023_finish (); + } + else + { + ffestc_V024_start (); + ffestc_V024_finish (); + } + } + ffestb_subr_kill_vxtcode_ (); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeNAME: + case FFELEX_typeOPEN_PAREN: + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + if (ffesta_first_kw == FFESTR_firstENCODE) + ffestc_V023_start (); + else + ffestc_V024_start (); + ffestb_subr_kill_vxtcode_ (); + if (ffesta_first_kw == FFESTR_firstDECODE) + next = (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextIOLISTDF, + (ffeexprCallback) ffestb_vxtcode10_); + else + next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextIOLISTDF, + (ffeexprCallback) ffestb_vxtcode10_); + + /* EXTENSION: Allow an optional preceding COMMA here if not pedantic. + (f2c provides this extension, as do other compilers, supposedly.) */ + + if (!ffe_is_pedantic () && (ffelex_token_type (t) == FFELEX_typeCOMMA)) + return next; + + return (ffelexHandler) (*next) (t); + + default: + break; + } + + ffestb_subr_kill_vxtcode_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_vxtcode10_ -- "VXTCODE(...)" expr + + (ffestb_vxtcode10_) // to expression handler + + Handle COMMA or EOS/SEMICOLON here. + + 07-Jun-90 JCB 1.1 + Context for ENCODE/DECODE expressions is now IOLISTDF instead of IOLIST + since they apply to internal files. */ + +static ffelexHandler +ffestb_vxtcode10_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + if (ffesta_first_kw == FFESTR_firstENCODE) + ffestc_V023_item (expr, ft); + else + ffestc_V024_item (expr, ft); + if (ffesta_first_kw == FFESTR_firstDECODE) + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextIOLISTDF, + (ffeexprCallback) ffestb_vxtcode10_); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextIOLISTDF, + (ffeexprCallback) ffestb_vxtcode10_); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + { + if (ffesta_first_kw == FFESTR_firstENCODE) + { + ffestc_V023_item (expr, ft); + ffestc_V023_finish (); + } + else + { + ffestc_V024_item (expr, ft); + ffestc_V024_finish (); + } + } + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + if (!ffesta_is_inhibited ()) + if (ffesta_first_kw == FFESTR_firstENCODE) + ffestc_V023_finish (); + else + ffestc_V024_finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.vxtcode.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_R904 -- Parse an OPEN statement + + return ffestb_R904; // to lexer + + Make sure the statement has a valid form for an OPEN statement. + If it does, implement the statement. */ + +ffelexHandler +ffestb_R904 (ffelexToken t) +{ + ffestpOpenIx ix; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstOPEN) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstOPEN) + goto bad_0; /* :::::::::::::::::::: */ + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlOPEN) + goto bad_0; /* :::::::::::::::::::: */ + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + for (ix = 0; ix < FFESTP_openix; ++ix) + ffestp_file.open.open_spec[ix].kw_or_val_present = FALSE; + + return (ffelexHandler) ffestb_R9041_; + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_R9041_ -- "OPEN" OPEN_PAREN + + return ffestb_R9041_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_R9041_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9042_; + + default: + return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_R9043_))) + (t); + } +} + +/* ffestb_R9042_ -- "OPEN" OPEN_PAREN NAME + + return ffestb_R9042_; // to lexer + + If EQUALS here, go to states that handle it. Else, send NAME and this + token thru expression handler. */ + +static ffelexHandler +ffestb_R9042_ (ffelexToken t) +{ + ffelexHandler next; + ffelexToken nt; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + nt = ffesta_tokens[1]; + next = (ffelexHandler) ffestb_R9044_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_R9043_))) + (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) (*next) (t); + } +} + +/* ffestb_R9043_ -- "OPEN" OPEN_PAREN expr + + (ffestb_R9043_) // to expression handler + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_R9043_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestp_file.open.open_spec[FFESTP_openixUNIT].kw_or_val_present + = TRUE; + ffestp_file.open.open_spec[FFESTP_openixUNIT].kw_present = FALSE; + ffestp_file.open.open_spec[FFESTP_openixUNIT].value_present = TRUE; + ffestp_file.open.open_spec[FFESTP_openixUNIT].value_is_label + = FALSE; + ffestp_file.open.open_spec[FFESTP_openixUNIT].value + = ffelex_token_use (ft); + ffestp_file.open.open_spec[FFESTP_openixUNIT].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_R9044_; + return (ffelexHandler) ffestb_R9049_; + + default: + break; + } + + ffestb_subr_kill_open_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9044_ -- "OPEN" OPEN_PAREN [external-file-unit COMMA] + + return ffestb_R9044_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_R9044_ (ffelexToken t) +{ + ffestrOpen kw; + + ffestb_local_.open.label = FALSE; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + kw = ffestr_open (t); + switch (kw) + { + case FFESTR_openACCESS: + ffestb_local_.open.ix = FFESTP_openixACCESS; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_openACTION: + ffestb_local_.open.ix = FFESTP_openixACTION; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_openASSOCIATEVARIABLE: + ffestb_local_.open.ix = FFESTP_openixASSOCIATEVARIABLE; + ffestb_local_.open.left = TRUE; + ffestb_local_.open.context = FFEEXPR_contextFILEASSOC; + break; + + case FFESTR_openBLANK: + ffestb_local_.open.ix = FFESTP_openixBLANK; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_openBLOCKSIZE: + ffestb_local_.open.ix = FFESTP_openixBLOCKSIZE; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILENUM; + break; + + case FFESTR_openBUFFERCOUNT: + ffestb_local_.open.ix = FFESTP_openixBUFFERCOUNT; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILENUM; + break; + + case FFESTR_openCARRIAGECONTROL: + ffestb_local_.open.ix = FFESTP_openixCARRIAGECONTROL; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILECHAR; + break; + + case FFESTR_openDEFAULTFILE: + ffestb_local_.open.ix = FFESTP_openixDEFAULTFILE; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILECHAR; + break; + + case FFESTR_openDELIM: + ffestb_local_.open.ix = FFESTP_openixDELIM; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_openDISP: + case FFESTR_openDISPOSE: + ffestb_local_.open.ix = FFESTP_openixDISPOSE; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILECHAR; + break; + + case FFESTR_openERR: + ffestb_local_.open.ix = FFESTP_openixERR; + ffestb_local_.open.label = TRUE; + break; + + case FFESTR_openEXTENDSIZE: + ffestb_local_.open.ix = FFESTP_openixEXTENDSIZE; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILENUM; + break; + + case FFESTR_openFILE: + case FFESTR_openNAME: + ffestb_local_.open.ix = FFESTP_openixFILE; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILECHAR; + break; + + case FFESTR_openFORM: + ffestb_local_.open.ix = FFESTP_openixFORM; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_openINITIALSIZE: + ffestb_local_.open.ix = FFESTP_openixINITIALSIZE; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILENUM; + break; + + case FFESTR_openIOSTAT: + ffestb_local_.open.ix = FFESTP_openixIOSTAT; + ffestb_local_.open.left = TRUE; + ffestb_local_.open.context = FFEEXPR_contextFILEINT; + break; + +#if 0 /* Haven't added support for expression + context yet (though easy). */ + case FFESTR_openKEY: + ffestb_local_.open.ix = FFESTP_openixKEY; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILEKEY; + break; +#endif + + case FFESTR_openMAXREC: + ffestb_local_.open.ix = FFESTP_openixMAXREC; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILENUM; + break; + + case FFESTR_openNOSPANBLOCKS: + if (ffestp_file.open.open_spec[FFESTP_openixNOSPANBLOCKS] + .kw_or_val_present) + goto bad; /* :::::::::::::::::::: */ + ffestp_file.open.open_spec[FFESTP_openixNOSPANBLOCKS] + .kw_or_val_present = TRUE; + ffestp_file.open.open_spec[FFESTP_openixNOSPANBLOCKS] + .kw_present = TRUE; + ffestp_file.open.open_spec[FFESTP_openixNOSPANBLOCKS] + .value_present = FALSE; + ffestp_file.open.open_spec[FFESTP_openixNOSPANBLOCKS].kw + = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9048_; + + case FFESTR_openORGANIZATION: + ffestb_local_.open.ix = FFESTP_openixORGANIZATION; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILECHAR; + break; + + case FFESTR_openPAD: + ffestb_local_.open.ix = FFESTP_openixPAD; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_openPOSITION: + ffestb_local_.open.ix = FFESTP_openixPOSITION; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_openREADONLY: + if (ffestp_file.open.open_spec[FFESTP_openixREADONLY] + .kw_or_val_present) + goto bad; /* :::::::::::::::::::: */ + ffestp_file.open.open_spec[FFESTP_openixREADONLY] + .kw_or_val_present = TRUE; + ffestp_file.open.open_spec[FFESTP_openixREADONLY] + .kw_present = TRUE; + ffestp_file.open.open_spec[FFESTP_openixREADONLY] + .value_present = FALSE; + ffestp_file.open.open_spec[FFESTP_openixREADONLY].kw + = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9048_; + + case FFESTR_openRECL: + case FFESTR_openRECORDSIZE: + ffestb_local_.open.ix = FFESTP_openixRECL; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILENUM; + break; + + case FFESTR_openRECORDTYPE: + ffestb_local_.open.ix = FFESTP_openixRECORDTYPE; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILECHAR; + break; + + case FFESTR_openSHARED: + if (ffestp_file.open.open_spec[FFESTP_openixSHARED] + .kw_or_val_present) + goto bad; /* :::::::::::::::::::: */ + ffestp_file.open.open_spec[FFESTP_openixSHARED] + .kw_or_val_present = TRUE; + ffestp_file.open.open_spec[FFESTP_openixSHARED] + .kw_present = TRUE; + ffestp_file.open.open_spec[FFESTP_openixSHARED] + .value_present = FALSE; + ffestp_file.open.open_spec[FFESTP_openixSHARED].kw + = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9048_; + + case FFESTR_openSTATUS: + case FFESTR_openTYPE: + ffestb_local_.open.ix = FFESTP_openixSTATUS; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_openUNIT: + ffestb_local_.open.ix = FFESTP_openixUNIT; + ffestb_local_.open.left = FALSE; + ffestb_local_.open.context = FFEEXPR_contextFILENUM; + break; + + case FFESTR_openUSEROPEN: + ffestb_local_.open.ix = FFESTP_openixUSEROPEN; + ffestb_local_.open.left = TRUE; + ffestb_local_.open.context = FFEEXPR_contextFILEEXTFUNC; + break; + + default: + goto bad; /* :::::::::::::::::::: */ + } + if (ffestp_file.open.open_spec[ffestb_local_.open.ix] + .kw_or_val_present) + break; /* Can't specify a keyword twice! */ + ffestp_file.open.open_spec[ffestb_local_.open.ix] + .kw_or_val_present = TRUE; + ffestp_file.open.open_spec[ffestb_local_.open.ix] + .kw_present = TRUE; + ffestp_file.open.open_spec[ffestb_local_.open.ix] + .value_present = FALSE; + ffestp_file.open.open_spec[ffestb_local_.open.ix].value_is_label + = ffestb_local_.open.label; + ffestp_file.open.open_spec[ffestb_local_.open.ix].kw + = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9045_; + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffestb_subr_kill_open_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9045_ -- "OPEN" OPEN_PAREN [external-file-unit COMMA] NAME + + return ffestb_R9045_; // to lexer + + Make sure EQUALS here, send next token to expression handler. */ + +static ffelexHandler +ffestb_R9045_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + ffesta_confirmed (); + if (ffestb_local_.open.label) + return (ffelexHandler) ffestb_R9047_; + if (ffestb_local_.open.left) + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + ffestb_local_.open.context, + (ffeexprCallback) ffestb_R9046_); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + ffestb_local_.open.context, + (ffeexprCallback) ffestb_R9046_); + + default: + break; + } + + ffestb_subr_kill_open_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9046_ -- "OPEN" OPEN_PAREN ... NAME EQUALS expr + + (ffestb_R9046_) // to expression handler + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_R9046_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestp_file.open.open_spec[ffestb_local_.open.ix].value_present + = TRUE; + ffestp_file.open.open_spec[ffestb_local_.open.ix].value + = ffelex_token_use (ft); + ffestp_file.open.open_spec[ffestb_local_.open.ix].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_R9044_; + return (ffelexHandler) ffestb_R9049_; + + default: + break; + } + + ffestb_subr_kill_open_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9047_ -- "OPEN" OPEN_PAREN ... NAME EQUALS + + return ffestb_R9047_; // to lexer + + Handle NUMBER for label here. */ + +static ffelexHandler +ffestb_R9047_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + ffestp_file.open.open_spec[ffestb_local_.open.ix].value_present + = TRUE; + ffestp_file.open.open_spec[ffestb_local_.open.ix].value + = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9048_; + + default: + break; + } + + ffestb_subr_kill_open_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9048_ -- "OPEN" OPEN_PAREN ... NAME EQUALS NUMBER + + return ffestb_R9048_; // to lexer + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_R9048_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_R9044_; + + case FFELEX_typeCLOSE_PAREN: + return (ffelexHandler) ffestb_R9049_; + + default: + break; + } + + ffestb_subr_kill_open_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9049_ -- "OPEN" OPEN_PAREN ... CLOSE_PAREN + + return ffestb_R9049_; // to lexer + + Handle EOS or SEMICOLON here. */ + +static ffelexHandler +ffestb_R9049_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R904 (); + ffestb_subr_kill_open_ (); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffestb_subr_kill_open_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "OPEN", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R907 -- Parse a CLOSE statement + + return ffestb_R907; // to lexer + + Make sure the statement has a valid form for a CLOSE statement. + If it does, implement the statement. */ + +ffelexHandler +ffestb_R907 (ffelexToken t) +{ + ffestpCloseIx ix; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstCLOSE) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstCLOSE) + goto bad_0; /* :::::::::::::::::::: */ + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlCLOSE) + goto bad_0; /* :::::::::::::::::::: */ + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + for (ix = 0; ix < FFESTP_closeix; ++ix) + ffestp_file.close.close_spec[ix].kw_or_val_present = FALSE; + + return (ffelexHandler) ffestb_R9071_; + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_R9071_ -- "CLOSE" OPEN_PAREN + + return ffestb_R9071_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_R9071_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9072_; + + default: + return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_R9073_))) + (t); + } +} + +/* ffestb_R9072_ -- "CLOSE" OPEN_PAREN NAME + + return ffestb_R9072_; // to lexer + + If EQUALS here, go to states that handle it. Else, send NAME and this + token thru expression handler. */ + +static ffelexHandler +ffestb_R9072_ (ffelexToken t) +{ + ffelexHandler next; + ffelexToken nt; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + nt = ffesta_tokens[1]; + next = (ffelexHandler) ffestb_R9074_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_R9073_))) + (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) (*next) (t); + } +} + +/* ffestb_R9073_ -- "CLOSE" OPEN_PAREN expr + + (ffestb_R9073_) // to expression handler + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_R9073_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestp_file.close.close_spec[FFESTP_closeixUNIT].kw_or_val_present + = TRUE; + ffestp_file.close.close_spec[FFESTP_closeixUNIT].kw_present = FALSE; + ffestp_file.close.close_spec[FFESTP_closeixUNIT].value_present = TRUE; + ffestp_file.close.close_spec[FFESTP_closeixUNIT].value_is_label + = FALSE; + ffestp_file.close.close_spec[FFESTP_closeixUNIT].value + = ffelex_token_use (ft); + ffestp_file.close.close_spec[FFESTP_closeixUNIT].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_R9074_; + return (ffelexHandler) ffestb_R9079_; + + default: + break; + } + + ffestb_subr_kill_close_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9074_ -- "CLOSE" OPEN_PAREN [external-file-unit COMMA] + + return ffestb_R9074_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_R9074_ (ffelexToken t) +{ + ffestrGenio kw; + + ffestb_local_.close.label = FALSE; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + kw = ffestr_genio (t); + switch (kw) + { + case FFESTR_genioERR: + ffestb_local_.close.ix = FFESTP_closeixERR; + ffestb_local_.close.label = TRUE; + break; + + case FFESTR_genioIOSTAT: + ffestb_local_.close.ix = FFESTP_closeixIOSTAT; + ffestb_local_.close.left = TRUE; + ffestb_local_.close.context = FFEEXPR_contextFILEINT; + break; + + case FFESTR_genioSTATUS: + case FFESTR_genioDISP: + case FFESTR_genioDISPOSE: + ffestb_local_.close.ix = FFESTP_closeixSTATUS; + ffestb_local_.close.left = FALSE; + ffestb_local_.close.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_genioUNIT: + ffestb_local_.close.ix = FFESTP_closeixUNIT; + ffestb_local_.close.left = FALSE; + ffestb_local_.close.context = FFEEXPR_contextFILENUM; + break; + + default: + goto bad; /* :::::::::::::::::::: */ + } + if (ffestp_file.close.close_spec[ffestb_local_.close.ix] + .kw_or_val_present) + break; /* Can't specify a keyword twice! */ + ffestp_file.close.close_spec[ffestb_local_.close.ix] + .kw_or_val_present = TRUE; + ffestp_file.close.close_spec[ffestb_local_.close.ix] + .kw_present = TRUE; + ffestp_file.close.close_spec[ffestb_local_.close.ix] + .value_present = FALSE; + ffestp_file.close.close_spec[ffestb_local_.close.ix].value_is_label + = ffestb_local_.close.label; + ffestp_file.close.close_spec[ffestb_local_.close.ix].kw + = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9075_; + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffestb_subr_kill_close_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9075_ -- "CLOSE" OPEN_PAREN [external-file-unit COMMA] NAME + + return ffestb_R9075_; // to lexer + + Make sure EQUALS here, send next token to expression handler. */ + +static ffelexHandler +ffestb_R9075_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + ffesta_confirmed (); + if (ffestb_local_.close.label) + return (ffelexHandler) ffestb_R9077_; + if (ffestb_local_.close.left) + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + ffestb_local_.close.context, + (ffeexprCallback) ffestb_R9076_); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + ffestb_local_.close.context, + (ffeexprCallback) ffestb_R9076_); + + default: + break; + } + + ffestb_subr_kill_close_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9076_ -- "CLOSE" OPEN_PAREN ... NAME EQUALS expr + + (ffestb_R9076_) // to expression handler + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_R9076_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestp_file.close.close_spec[ffestb_local_.close.ix].value_present + = TRUE; + ffestp_file.close.close_spec[ffestb_local_.close.ix].value + = ffelex_token_use (ft); + ffestp_file.close.close_spec[ffestb_local_.close.ix].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_R9074_; + return (ffelexHandler) ffestb_R9079_; + + default: + break; + } + + ffestb_subr_kill_close_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9077_ -- "CLOSE" OPEN_PAREN ... NAME EQUALS + + return ffestb_R9077_; // to lexer + + Handle NUMBER for label here. */ + +static ffelexHandler +ffestb_R9077_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + ffestp_file.close.close_spec[ffestb_local_.close.ix].value_present + = TRUE; + ffestp_file.close.close_spec[ffestb_local_.close.ix].value + = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9078_; + + default: + break; + } + + ffestb_subr_kill_close_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9078_ -- "CLOSE" OPEN_PAREN ... NAME EQUALS NUMBER + + return ffestb_R9078_; // to lexer + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_R9078_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_R9074_; + + case FFELEX_typeCLOSE_PAREN: + return (ffelexHandler) ffestb_R9079_; + + default: + break; + } + + ffestb_subr_kill_close_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9079_ -- "CLOSE" OPEN_PAREN ... CLOSE_PAREN + + return ffestb_R9079_; // to lexer + + Handle EOS or SEMICOLON here. */ + +static ffelexHandler +ffestb_R9079_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R907 (); + ffestb_subr_kill_close_ (); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffestb_subr_kill_close_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "CLOSE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R909 -- Parse the READ statement + + return ffestb_R909; // to lexer + + Make sure the statement has a valid form for the READ + statement. If it does, implement the statement. */ + +ffelexHandler +ffestb_R909 (ffelexToken t) +{ + ffelexHandler next; + ffestpReadIx ix; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstREAD) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + case FFELEX_typeCOLON: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + case FFELEX_typeNUMBER: + ffesta_confirmed (); + break; + + case FFELEX_typeOPEN_PAREN: + for (ix = 0; ix < FFESTP_readix; ++ix) + ffestp_file.read.read_spec[ix].kw_or_val_present = FALSE; + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9092_; + + default: + break; + } + + for (ix = 0; ix < FFESTP_readix; ++ix) + ffestp_file.read.read_spec[ix].kw_or_val_present = FALSE; + return (ffelexHandler) (*((ffelexHandler) + ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9091_))) + (t); + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstREAD) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlREAD) + break; + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + case FFELEX_typeCOLON: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlREAD) + break; + + for (ix = 0; ix < FFESTP_readix; ++ix) + ffestp_file.read.read_spec[ix].kw_or_val_present = FALSE; + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9092_; + + default: + break; + } + for (ix = 0; ix < FFESTP_readix; ++ix) + ffestp_file.read.read_spec[ix].kw_or_val_present = FALSE; + next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9091_); + next = (ffelexHandler) ffelex_splice_tokens (next, ffesta_tokens[0], + FFESTR_firstlREAD); + if (next == NULL) + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + return (ffelexHandler) (*next) (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_R9091_ -- "READ" expr + + (ffestb_R9091_) // to expression handler + + Make sure the next token is a COMMA or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_R9091_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + ffesta_confirmed (); + ffestp_file.read.read_spec[FFESTP_readixFORMAT].kw_or_val_present + = TRUE; + ffestp_file.read.read_spec[FFESTP_readixFORMAT].kw_present = FALSE; + ffestp_file.read.read_spec[FFESTP_readixFORMAT].value_present = TRUE; + ffestp_file.read.read_spec[FFESTP_readixFORMAT].value_is_label + = (expr == NULL); + ffestp_file.read.read_spec[FFESTP_readixFORMAT].value + = ffelex_token_use (ft); + ffestp_file.read.read_spec[FFESTP_readixFORMAT].u.expr = expr; + if (!ffesta_is_inhibited ()) + ffestc_R909_start (TRUE); + ffestb_subr_kill_read_ (); + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + ffestc_context_iolist (), + (ffeexprCallback) ffestb_R90915_); + if (!ffesta_is_inhibited ()) + ffestc_R909_finish (); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffestb_subr_kill_read_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9092_ -- "READ" OPEN_PAREN + + return ffestb_R9092_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_R9092_ (ffelexToken t) +{ + ffelexToken nt; + ffelexHandler next; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[2] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9093_; + + default: + nt = ffesta_tokens[1]; + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEUNITAMBIG, (ffeexprCallback) ffestb_R9094_))) + (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + } +} + +/* ffestb_R9093_ -- "READ" OPEN_PAREN NAME + + return ffestb_R9093_; // to lexer + + If EQUALS here, go to states that handle it. Else, send NAME and this + token thru expression handler. */ + +static ffelexHandler +ffestb_R9093_ (ffelexToken t) +{ + ffelexHandler next; + ffelexToken nt; + ffelexToken ot; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + ffelex_token_kill (ffesta_tokens[1]); + nt = ffesta_tokens[2]; + next = (ffelexHandler) ffestb_R9098_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + nt = ffesta_tokens[1]; + ot = ffesta_tokens[2]; + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEUNITAMBIG, (ffeexprCallback) ffestb_R9094_))) + (nt); + ffelex_token_kill (nt); + next = (ffelexHandler) (*next) (ot); + ffelex_token_kill (ot); + return (ffelexHandler) (*next) (t); + } +} + +/* ffestb_R9094_ -- "READ" OPEN_PAREN expr [CLOSE_PAREN] + + (ffestb_R9094_) // to expression handler + + Handle COMMA or EOS/SEMICOLON here. + + 15-Feb-91 JCB 1.1 + Use new ffeexpr mechanism whereby the expr is encased in an opITEM if + ffeexpr decided it was an item in a control list (hence a unit + specifier), or a format specifier otherwise. */ + +static ffelexHandler +ffestb_R9094_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + if (expr == NULL) + goto bad; /* :::::::::::::::::::: */ + + if (ffebld_op (expr) != FFEBLD_opITEM) + { + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + ffestp_file.read.read_spec[FFESTP_readixFORMAT].kw_or_val_present + = TRUE; + ffestp_file.read.read_spec[FFESTP_readixFORMAT].kw_present = FALSE; + ffestp_file.read.read_spec[FFESTP_readixFORMAT].value_present = TRUE; + ffestp_file.read.read_spec[FFESTP_readixFORMAT].value_is_label + = FALSE; + ffestp_file.read.read_spec[FFESTP_readixFORMAT].value + = ffelex_token_use (ft); + ffestp_file.read.read_spec[FFESTP_readixFORMAT].u.expr = expr; + if (!ffesta_is_inhibited ()) + ffestc_R909_start (TRUE); + ffestb_subr_kill_read_ (); + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) + ffeexpr_lhs (ffesta_output_pool, + ffestc_context_iolist (), + (ffeexprCallback) ffestb_R90915_); + if (!ffesta_is_inhibited ()) + ffestc_R909_finish (); + return (ffelexHandler) ffesta_zero (t); + + default: + goto bad; /* :::::::::::::::::::: */ + } + } + + expr = ffebld_head (expr); + + if (expr == NULL) + goto bad; /* :::::::::::::::::::: */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + ffestp_file.read.read_spec[FFESTP_readixUNIT].kw_or_val_present + = TRUE; + ffestp_file.read.read_spec[FFESTP_readixUNIT].kw_present = FALSE; + ffestp_file.read.read_spec[FFESTP_readixUNIT].value_present = TRUE; + ffestp_file.read.read_spec[FFESTP_readixUNIT].value_is_label + = FALSE; + ffestp_file.read.read_spec[FFESTP_readixUNIT].value + = ffelex_token_use (ft); + ffestp_file.read.read_spec[FFESTP_readixUNIT].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_R9095_; + return (ffelexHandler) ffestb_R90913_; + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffestb_subr_kill_read_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9095_ -- "READ" OPEN_PAREN expr COMMA + + return ffestb_R9095_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_R9095_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9096_; + + default: + return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9097_))) + (t); + } +} + +/* ffestb_R9096_ -- "READ" OPEN_PAREN expr COMMA NAME + + return ffestb_R9096_; // to lexer + + If EQUALS here, go to states that handle it. Else, send NAME and this + token thru expression handler. */ + +static ffelexHandler +ffestb_R9096_ (ffelexToken t) +{ + ffelexHandler next; + ffelexToken nt; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + nt = ffesta_tokens[1]; + next = (ffelexHandler) ffestb_R9098_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + nt = ffesta_tokens[1]; + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9097_))) + (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + } +} + +/* ffestb_R9097_ -- "READ" OPEN_PAREN expr COMMA expr + + (ffestb_R9097_) // to expression handler + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_R9097_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + ffestp_file.read.read_spec[FFESTP_readixFORMAT].kw_or_val_present + = TRUE; + ffestp_file.read.read_spec[FFESTP_readixFORMAT].kw_present = FALSE; + ffestp_file.read.read_spec[FFESTP_readixFORMAT].value_present = TRUE; + ffestp_file.read.read_spec[FFESTP_readixFORMAT].value_is_label + = (expr == NULL); + ffestp_file.read.read_spec[FFESTP_readixFORMAT].value + = ffelex_token_use (ft); + ffestp_file.read.read_spec[FFESTP_readixFORMAT].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_R9098_; + return (ffelexHandler) ffestb_R90913_; + + default: + break; + } + + ffestb_subr_kill_read_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9098_ -- "READ" OPEN_PAREN [external-file-unit COMMA [format + COMMA]] + + return ffestb_R9098_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_R9098_ (ffelexToken t) +{ + ffestrGenio kw; + + ffestb_local_.read.label = FALSE; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + kw = ffestr_genio (t); + switch (kw) + { + case FFESTR_genioADVANCE: + ffestb_local_.read.ix = FFESTP_readixADVANCE; + ffestb_local_.read.left = FALSE; + ffestb_local_.read.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_genioEOR: + ffestb_local_.read.ix = FFESTP_readixEOR; + ffestb_local_.read.label = TRUE; + break; + + case FFESTR_genioERR: + ffestb_local_.read.ix = FFESTP_readixERR; + ffestb_local_.read.label = TRUE; + break; + + case FFESTR_genioEND: + ffestb_local_.read.ix = FFESTP_readixEND; + ffestb_local_.read.label = TRUE; + break; + + case FFESTR_genioFMT: + ffestb_local_.read.ix = FFESTP_readixFORMAT; + ffestb_local_.read.left = FALSE; + ffestb_local_.read.context = FFEEXPR_contextFILEFORMAT; + break; + + case FFESTR_genioIOSTAT: + ffestb_local_.read.ix = FFESTP_readixIOSTAT; + ffestb_local_.read.left = TRUE; + ffestb_local_.read.context = FFEEXPR_contextFILEINT; + break; + + case FFESTR_genioKEY: + case FFESTR_genioKEYEQ: + ffestb_local_.read.ix = FFESTP_readixKEYEQ; + ffestb_local_.read.left = FALSE; + ffestb_local_.read.context = FFEEXPR_contextFILENUMCHAR; + break; + + case FFESTR_genioKEYGE: + ffestb_local_.read.ix = FFESTP_readixKEYGE; + ffestb_local_.read.left = FALSE; + ffestb_local_.read.context = FFEEXPR_contextFILENUMCHAR; + break; + + case FFESTR_genioKEYGT: + ffestb_local_.read.ix = FFESTP_readixKEYGT; + ffestb_local_.read.left = FALSE; + ffestb_local_.read.context = FFEEXPR_contextFILENUMCHAR; + break; + + case FFESTR_genioKEYID: + ffestb_local_.read.ix = FFESTP_readixKEYID; + ffestb_local_.read.left = FALSE; + ffestb_local_.read.context = FFEEXPR_contextFILENUM; + break; + + case FFESTR_genioNML: + ffestb_local_.read.ix = FFESTP_readixFORMAT; + ffestb_local_.read.left = TRUE; + ffestb_local_.read.context = FFEEXPR_contextFILENAMELIST; + break; + + case FFESTR_genioNULLS: + ffestb_local_.read.ix = FFESTP_readixNULLS; + ffestb_local_.read.left = TRUE; + ffestb_local_.read.context = FFEEXPR_contextFILEINT; + break; + + case FFESTR_genioREC: + ffestb_local_.read.ix = FFESTP_readixREC; + ffestb_local_.read.left = FALSE; + ffestb_local_.read.context = FFEEXPR_contextFILENUM; + break; + + case FFESTR_genioSIZE: + ffestb_local_.read.ix = FFESTP_readixSIZE; + ffestb_local_.read.left = TRUE; + ffestb_local_.read.context = FFEEXPR_contextFILEINT; + break; + + case FFESTR_genioUNIT: + ffestb_local_.read.ix = FFESTP_readixUNIT; + ffestb_local_.read.left = FALSE; + ffestb_local_.read.context = FFEEXPR_contextFILEUNIT; + break; + + default: + goto bad; /* :::::::::::::::::::: */ + } + if (ffestp_file.read.read_spec[ffestb_local_.read.ix] + .kw_or_val_present) + break; /* Can't specify a keyword twice! */ + ffestp_file.read.read_spec[ffestb_local_.read.ix] + .kw_or_val_present = TRUE; + ffestp_file.read.read_spec[ffestb_local_.read.ix] + .kw_present = TRUE; + ffestp_file.read.read_spec[ffestb_local_.read.ix] + .value_present = FALSE; + ffestp_file.read.read_spec[ffestb_local_.read.ix].value_is_label + = ffestb_local_.read.label; + ffestp_file.read.read_spec[ffestb_local_.read.ix].kw + = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9099_; + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffestb_subr_kill_read_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9099_ -- "READ" OPEN_PAREN [external-file-unit COMMA [format + COMMA]] NAME + + return ffestb_R9099_; // to lexer + + Make sure EQUALS here, send next token to expression handler. */ + +static ffelexHandler +ffestb_R9099_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + ffesta_confirmed (); + if (ffestb_local_.read.label) + return (ffelexHandler) ffestb_R90911_; + if (ffestb_local_.read.left) + return (ffelexHandler) + ffeexpr_lhs (ffesta_output_pool, + ffestb_local_.read.context, + (ffeexprCallback) ffestb_R90910_); + return (ffelexHandler) + ffeexpr_rhs (ffesta_output_pool, + ffestb_local_.read.context, + (ffeexprCallback) ffestb_R90910_); + + default: + break; + } + + ffestb_subr_kill_read_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R90910_ -- "READ" OPEN_PAREN ... NAME EQUALS expr + + (ffestb_R90910_) // to expression handler + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_R90910_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + if (ffestb_local_.read.context == FFEEXPR_contextFILEFORMAT) + ffestp_file.read.read_spec[ffestb_local_.read.ix] + .value_is_label = TRUE; + else + break; + ffestp_file.read.read_spec[ffestb_local_.read.ix].value_present + = TRUE; + ffestp_file.read.read_spec[ffestb_local_.read.ix].value + = ffelex_token_use (ft); + ffestp_file.read.read_spec[ffestb_local_.read.ix].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_R9098_; + return (ffelexHandler) ffestb_R90913_; + + default: + break; + } + + ffestb_subr_kill_read_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R90911_ -- "READ" OPEN_PAREN ... NAME EQUALS + + return ffestb_R90911_; // to lexer + + Handle NUMBER for label here. */ + +static ffelexHandler +ffestb_R90911_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + ffestp_file.read.read_spec[ffestb_local_.read.ix].value_present + = TRUE; + ffestp_file.read.read_spec[ffestb_local_.read.ix].value + = ffelex_token_use (t); + return (ffelexHandler) ffestb_R90912_; + + default: + break; + } + + ffestb_subr_kill_read_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R90912_ -- "READ" OPEN_PAREN ... NAME EQUALS NUMBER + + return ffestb_R90912_; // to lexer + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_R90912_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_R9098_; + + case FFELEX_typeCLOSE_PAREN: + return (ffelexHandler) ffestb_R90913_; + + default: + break; + } + + ffestb_subr_kill_read_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R90913_ -- "READ" OPEN_PAREN ... CLOSE_PAREN + + return ffestb_R90913_; // to lexer + + Handle EOS or SEMICOLON here. + + 15-Feb-91 JCB 1.1 + Fix to allow implied-DO construct here (OPEN_PAREN) -- actually, + don't presume knowledge of what an initial token in an lhs context + is going to be, let ffeexpr_lhs handle that as much as possible. */ + +static ffelexHandler +ffestb_R90913_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + ffestc_R909_start (FALSE); + ffestc_R909_finish (); + } + ffestb_subr_kill_read_ (); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_confirmed (); + /* Fall through. */ + case FFELEX_typeOPEN_PAREN: /* Could still be assignment!! */ + break; + } + + /* If token isn't NAME or OPEN_PAREN, ffeexpr_lhs will ultimately whine + about it, so leave it up to that code. */ + + /* EXTENSION: Allow an optional preceding COMMA here if not pedantic. (f2c + provides this extension, as do other compilers, supposedly.) */ + + if (!ffe_is_pedantic () && (ffelex_token_type (t) == FFELEX_typeCOMMA)) + return (ffelexHandler) + ffeexpr_lhs (ffesta_output_pool, + ffestc_context_iolist (), + (ffeexprCallback) ffestb_R90914_); + + return (ffelexHandler) (*((ffelexHandler) + ffeexpr_lhs (ffesta_output_pool, + ffestc_context_iolist (), + (ffeexprCallback) ffestb_R90914_))) + (t); +} + +/* ffestb_R90914_ -- "READ(...)" expr + + (ffestb_R90914_) // to expression handler + + Handle COMMA or EOS/SEMICOLON here. */ + +static ffelexHandler +ffestb_R90914_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R909_start (FALSE); + ffestb_subr_kill_read_ (); + + if (!ffesta_is_inhibited ()) + ffestc_R909_item (expr, ft); + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + ffestc_context_iolist (), + (ffeexprCallback) ffestb_R90915_); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (expr == NULL) + break; + + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R909_start (FALSE); + ffestb_subr_kill_read_ (); + + if (!ffesta_is_inhibited ()) + { + ffestc_R909_item (expr, ft); + ffestc_R909_finish (); + } + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffestb_subr_kill_read_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R90915_ -- "READ(...)" expr COMMA expr + + (ffestb_R90915_) // to expression handler + + Handle COMMA or EOS/SEMICOLON here. */ + +static ffelexHandler +ffestb_R90915_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + ffestc_R909_item (expr, ft); + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + ffestc_context_iolist (), + (ffeexprCallback) ffestb_R90915_); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + { + ffestc_R909_item (expr, ft); + ffestc_R909_finish (); + } + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R909_finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "READ", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R910 -- Parse the WRITE statement + + return ffestb_R910; // to lexer + + Make sure the statement has a valid form for the WRITE + statement. If it does, implement the statement. */ + +ffelexHandler +ffestb_R910 (ffelexToken t) +{ + ffestpWriteIx ix; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstWRITE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeNAME: + case FFELEX_typeNUMBER: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + for (ix = 0; ix < FFESTP_writeix; ++ix) + ffestp_file.write.write_spec[ix].kw_or_val_present = FALSE; + return (ffelexHandler) ffestb_R9101_; + } + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstWRITE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlWRITE) + goto bad_0; /* :::::::::::::::::::: */ + + for (ix = 0; ix < FFESTP_writeix; ++ix) + ffestp_file.write.write_spec[ix].kw_or_val_present = FALSE; + return (ffelexHandler) ffestb_R9101_; + } + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_R9101_ -- "WRITE" OPEN_PAREN + + return ffestb_R9101_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_R9101_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9102_; + + default: + return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEUNIT, (ffeexprCallback) ffestb_R9103_))) + (t); + } +} + +/* ffestb_R9102_ -- "WRITE" OPEN_PAREN NAME + + return ffestb_R9102_; // to lexer + + If EQUALS here, go to states that handle it. Else, send NAME and this + token thru expression handler. */ + +static ffelexHandler +ffestb_R9102_ (ffelexToken t) +{ + ffelexHandler next; + ffelexToken nt; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + nt = ffesta_tokens[1]; + next = (ffelexHandler) ffestb_R9107_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + nt = ffesta_tokens[1]; + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEUNIT, (ffeexprCallback) ffestb_R9103_))) + (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + } +} + +/* ffestb_R9103_ -- "WRITE" OPEN_PAREN expr [CLOSE_PAREN] + + (ffestb_R9103_) // to expression handler + + Handle COMMA or EOS/SEMICOLON here. */ + +static ffelexHandler +ffestb_R9103_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestp_file.write.write_spec[FFESTP_writeixUNIT].kw_or_val_present + = TRUE; + ffestp_file.write.write_spec[FFESTP_writeixUNIT].kw_present = FALSE; + ffestp_file.write.write_spec[FFESTP_writeixUNIT].value_present = TRUE; + ffestp_file.write.write_spec[FFESTP_writeixUNIT].value_is_label + = FALSE; + ffestp_file.write.write_spec[FFESTP_writeixUNIT].value + = ffelex_token_use (ft); + ffestp_file.write.write_spec[FFESTP_writeixUNIT].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_R9104_; + return (ffelexHandler) ffestb_R91012_; + + default: + break; + } + + ffestb_subr_kill_write_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9104_ -- "WRITE" OPEN_PAREN expr COMMA + + return ffestb_R9104_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_R9104_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9105_; + + default: + return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9106_))) + (t); + } +} + +/* ffestb_R9105_ -- "WRITE" OPEN_PAREN expr COMMA NAME + + return ffestb_R9105_; // to lexer + + If EQUALS here, go to states that handle it. Else, send NAME and this + token thru expression handler. */ + +static ffelexHandler +ffestb_R9105_ (ffelexToken t) +{ + ffelexHandler next; + ffelexToken nt; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + nt = ffesta_tokens[1]; + next = (ffelexHandler) ffestb_R9107_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + nt = ffesta_tokens[1]; + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9106_))) + (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + } +} + +/* ffestb_R9106_ -- "WRITE" OPEN_PAREN expr COMMA expr + + (ffestb_R9106_) // to expression handler + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_R9106_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + ffestp_file.write.write_spec[FFESTP_writeixFORMAT].kw_or_val_present + = TRUE; + ffestp_file.write.write_spec[FFESTP_writeixFORMAT].kw_present = FALSE; + ffestp_file.write.write_spec[FFESTP_writeixFORMAT].value_present = TRUE; + ffestp_file.write.write_spec[FFESTP_writeixFORMAT].value_is_label + = (expr == NULL); + ffestp_file.write.write_spec[FFESTP_writeixFORMAT].value + = ffelex_token_use (ft); + ffestp_file.write.write_spec[FFESTP_writeixFORMAT].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_R9107_; + return (ffelexHandler) ffestb_R91012_; + + default: + break; + } + + ffestb_subr_kill_write_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9107_ -- "WRITE" OPEN_PAREN [external-file-unit COMMA [format + COMMA]] + + return ffestb_R9107_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_R9107_ (ffelexToken t) +{ + ffestrGenio kw; + + ffestb_local_.write.label = FALSE; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + kw = ffestr_genio (t); + switch (kw) + { + case FFESTR_genioADVANCE: + ffestb_local_.write.ix = FFESTP_writeixADVANCE; + ffestb_local_.write.left = FALSE; + ffestb_local_.write.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_genioEOR: + ffestb_local_.write.ix = FFESTP_writeixEOR; + ffestb_local_.write.label = TRUE; + break; + + case FFESTR_genioERR: + ffestb_local_.write.ix = FFESTP_writeixERR; + ffestb_local_.write.label = TRUE; + break; + + case FFESTR_genioFMT: + ffestb_local_.write.ix = FFESTP_writeixFORMAT; + ffestb_local_.write.left = FALSE; + ffestb_local_.write.context = FFEEXPR_contextFILEFORMAT; + break; + + case FFESTR_genioIOSTAT: + ffestb_local_.write.ix = FFESTP_writeixIOSTAT; + ffestb_local_.write.left = TRUE; + ffestb_local_.write.context = FFEEXPR_contextFILEINT; + break; + + case FFESTR_genioNML: + ffestb_local_.write.ix = FFESTP_writeixFORMAT; + ffestb_local_.write.left = TRUE; + ffestb_local_.write.context = FFEEXPR_contextFILENAMELIST; + break; + + case FFESTR_genioREC: + ffestb_local_.write.ix = FFESTP_writeixREC; + ffestb_local_.write.left = FALSE; + ffestb_local_.write.context = FFEEXPR_contextFILENUM; + break; + + case FFESTR_genioUNIT: + ffestb_local_.write.ix = FFESTP_writeixUNIT; + ffestb_local_.write.left = FALSE; + ffestb_local_.write.context = FFEEXPR_contextFILEUNIT; + break; + + default: + goto bad; /* :::::::::::::::::::: */ + } + if (ffestp_file.write.write_spec[ffestb_local_.write.ix] + .kw_or_val_present) + break; /* Can't specify a keyword twice! */ + ffestp_file.write.write_spec[ffestb_local_.write.ix] + .kw_or_val_present = TRUE; + ffestp_file.write.write_spec[ffestb_local_.write.ix] + .kw_present = TRUE; + ffestp_file.write.write_spec[ffestb_local_.write.ix] + .value_present = FALSE; + ffestp_file.write.write_spec[ffestb_local_.write.ix].value_is_label + = ffestb_local_.write.label; + ffestp_file.write.write_spec[ffestb_local_.write.ix].kw + = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9108_; + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffestb_subr_kill_write_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9108_ -- "WRITE" OPEN_PAREN [external-file-unit COMMA [format + COMMA]] NAME + + return ffestb_R9108_; // to lexer + + Make sure EQUALS here, send next token to expression handler. */ + +static ffelexHandler +ffestb_R9108_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + ffesta_confirmed (); + if (ffestb_local_.write.label) + return (ffelexHandler) ffestb_R91010_; + if (ffestb_local_.write.left) + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + ffestb_local_.write.context, + (ffeexprCallback) ffestb_R9109_); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + ffestb_local_.write.context, + (ffeexprCallback) ffestb_R9109_); + + default: + break; + } + + ffestb_subr_kill_write_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9109_ -- "WRITE" OPEN_PAREN ... NAME EQUALS expr + + (ffestb_R9109_) // to expression handler + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_R9109_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + if (ffestb_local_.write.context == FFEEXPR_contextFILEFORMAT) + ffestp_file.write.write_spec[ffestb_local_.write.ix] + .value_is_label = TRUE; + else + break; + ffestp_file.write.write_spec[ffestb_local_.write.ix].value_present + = TRUE; + ffestp_file.write.write_spec[ffestb_local_.write.ix].value + = ffelex_token_use (ft); + ffestp_file.write.write_spec[ffestb_local_.write.ix].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_R9107_; + return (ffelexHandler) ffestb_R91012_; + + default: + break; + } + + ffestb_subr_kill_write_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R91010_ -- "WRITE" OPEN_PAREN ... NAME EQUALS + + return ffestb_R91010_; // to lexer + + Handle NUMBER for label here. */ + +static ffelexHandler +ffestb_R91010_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + ffestp_file.write.write_spec[ffestb_local_.write.ix].value_present + = TRUE; + ffestp_file.write.write_spec[ffestb_local_.write.ix].value + = ffelex_token_use (t); + return (ffelexHandler) ffestb_R91011_; + + default: + break; + } + + ffestb_subr_kill_write_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R91011_ -- "WRITE" OPEN_PAREN ... NAME EQUALS NUMBER + + return ffestb_R91011_; // to lexer + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_R91011_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_R9107_; + + case FFELEX_typeCLOSE_PAREN: + return (ffelexHandler) ffestb_R91012_; + + default: + break; + } + + ffestb_subr_kill_write_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R91012_ -- "WRITE" OPEN_PAREN ... CLOSE_PAREN + + return ffestb_R91012_; // to lexer + + Handle EOS or SEMICOLON here. */ + +static ffelexHandler +ffestb_R91012_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + ffestc_R910_start (); + ffestc_R910_finish (); + } + ffestb_subr_kill_write_ (); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_confirmed (); + /* Fall through. */ + case FFELEX_typeOPEN_PAREN: /* Could still be assignment!! */ + + /* EXTENSION: Allow an optional preceding COMMA here if not pedantic. + (f2c provides this extension, as do other compilers, supposedly.) */ + + if (!ffe_is_pedantic () && (ffelex_token_type (t) == FFELEX_typeCOMMA)) + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + ffestc_context_iolist (), (ffeexprCallback) ffestb_R91013_); + + return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + ffestc_context_iolist (), (ffeexprCallback) ffestb_R91013_))) + (t); + + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + break; + } + + ffestb_subr_kill_write_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R91013_ -- "WRITE(...)" expr + + (ffestb_R91013_) // to expression handler + + Handle COMMA or EOS/SEMICOLON here. */ + +static ffelexHandler +ffestb_R91013_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R910_start (); + ffestb_subr_kill_write_ (); + + if (!ffesta_is_inhibited ()) + ffestc_R910_item (expr, ft); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + ffestc_context_iolist (), (ffeexprCallback) ffestb_R91014_); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (expr == NULL) + break; + + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R910_start (); + ffestb_subr_kill_write_ (); + + if (!ffesta_is_inhibited ()) + { + ffestc_R910_item (expr, ft); + ffestc_R910_finish (); + } + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffestb_subr_kill_write_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R91014_ -- "WRITE(...)" expr COMMA expr + + (ffestb_R91014_) // to expression handler + + Handle COMMA or EOS/SEMICOLON here. */ + +static ffelexHandler +ffestb_R91014_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + ffestc_R910_item (expr, ft); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + ffestc_context_iolist (), (ffeexprCallback) ffestb_R91014_); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + { + ffestc_R910_item (expr, ft); + ffestc_R910_finish (); + } + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R910_finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "WRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R911 -- Parse the PRINT statement + + return ffestb_R911; // to lexer + + Make sure the statement has a valid form for the PRINT + statement. If it does, implement the statement. */ + +ffelexHandler +ffestb_R911 (ffelexToken t) +{ + ffelexHandler next; + ffestpPrintIx ix; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstPRINT) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + case FFELEX_typeCOLON: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + case FFELEX_typeNUMBER: + ffesta_confirmed (); + break; + + default: + break; + } + + for (ix = 0; ix < FFESTP_printix; ++ix) + ffestp_file.print.print_spec[ix].kw_or_val_present = FALSE; + return (ffelexHandler) (*((ffelexHandler) + ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9111_))) + (t); + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstPRINT) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlPRINT) + break; + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + case FFELEX_typeCOLON: + goto bad_1; /* :::::::::::::::::::: */ + + default: + break; + } + for (ix = 0; ix < FFESTP_printix; ++ix) + ffestp_file.print.print_spec[ix].kw_or_val_present = FALSE; + next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_R9111_); + next = (ffelexHandler) ffelex_splice_tokens (next, ffesta_tokens[0], + FFESTR_firstlPRINT); + if (next == NULL) + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + return (ffelexHandler) (*next) (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PRINT", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PRINT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_R9111_ -- "PRINT" expr + + (ffestb_R9111_) // to expression handler + + Make sure the next token is a COMMA or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_R9111_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + ffesta_confirmed (); + ffestp_file.print.print_spec[FFESTP_printixFORMAT].kw_or_val_present + = TRUE; + ffestp_file.print.print_spec[FFESTP_printixFORMAT].kw_present = FALSE; + ffestp_file.print.print_spec[FFESTP_printixFORMAT].value_present = TRUE; + ffestp_file.print.print_spec[FFESTP_printixFORMAT].value_is_label + = (expr == NULL); + ffestp_file.print.print_spec[FFESTP_printixFORMAT].value + = ffelex_token_use (ft); + ffestp_file.print.print_spec[FFESTP_printixFORMAT].u.expr = expr; + if (!ffesta_is_inhibited ()) + ffestc_R911_start (); + ffestb_subr_kill_print_ (); + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_R9112_); + if (!ffesta_is_inhibited ()) + ffestc_R911_finish (); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffestb_subr_kill_print_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PRINT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9112_ -- "PRINT" expr COMMA expr + + (ffestb_R9112_) // to expression handler + + Handle COMMA or EOS/SEMICOLON here. */ + +static ffelexHandler +ffestb_R9112_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + ffestc_R911_item (expr, ft); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_R9112_); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + { + ffestc_R911_item (expr, ft); + ffestc_R911_finish (); + } + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R911_finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PRINT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R923 -- Parse an INQUIRE statement + + return ffestb_R923; // to lexer + + Make sure the statement has a valid form for an INQUIRE statement. + If it does, implement the statement. */ + +ffelexHandler +ffestb_R923 (ffelexToken t) +{ + ffestpInquireIx ix; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstINQUIRE) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstINQUIRE) + goto bad_0; /* :::::::::::::::::::: */ + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlINQUIRE) + goto bad_0; /* :::::::::::::::::::: */ + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + for (ix = 0; ix < FFESTP_inquireix; ++ix) + ffestp_file.inquire.inquire_spec[ix].kw_or_val_present = FALSE; + + ffestb_local_.inquire.may_be_iolength = TRUE; + return (ffelexHandler) ffestb_R9231_; + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_R9231_ -- "INQUIRE" OPEN_PAREN + + return ffestb_R9231_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_R9231_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9232_; + + default: + ffestb_local_.inquire.may_be_iolength = FALSE; + return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_R9233_))) + (t); + } +} + +/* ffestb_R9232_ -- "INQUIRE" OPEN_PAREN NAME + + return ffestb_R9232_; // to lexer + + If EQUALS here, go to states that handle it. Else, send NAME and this + token thru expression handler. */ + +static ffelexHandler +ffestb_R9232_ (ffelexToken t) +{ + ffelexHandler next; + ffelexToken nt; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + nt = ffesta_tokens[1]; + next = (ffelexHandler) ffestb_R9234_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + ffestb_local_.inquire.may_be_iolength = FALSE; + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_R9233_))) + (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) (*next) (t); + } +} + +/* ffestb_R9233_ -- "INQUIRE" OPEN_PAREN expr + + (ffestb_R9233_) // to expression handler + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_R9233_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_or_val_present + = TRUE; + ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].kw_present = FALSE; + ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value_present = TRUE; + ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value_is_label + = FALSE; + ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].value + = ffelex_token_use (ft); + ffestp_file.inquire.inquire_spec[FFESTP_inquireixUNIT].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_R9234_; + return (ffelexHandler) ffestb_R9239_; + + default: + break; + } + + ffestb_subr_kill_inquire_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9234_ -- "INQUIRE" OPEN_PAREN [external-file-unit COMMA] + + return ffestb_R9234_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_R9234_ (ffelexToken t) +{ + ffestrInquire kw; + + ffestb_local_.inquire.label = FALSE; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + kw = ffestr_inquire (t); + if (kw != FFESTR_inquireIOLENGTH) + ffestb_local_.inquire.may_be_iolength = FALSE; + switch (kw) + { + case FFESTR_inquireACCESS: + ffestb_local_.inquire.ix = FFESTP_inquireixACCESS; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_inquireACTION: + ffestb_local_.inquire.ix = FFESTP_inquireixACTION; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_inquireBLANK: + ffestb_local_.inquire.ix = FFESTP_inquireixBLANK; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_inquireCARRIAGECONTROL: + ffestb_local_.inquire.ix = FFESTP_inquireixCARRIAGECONTROL; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR; + break; + + case FFESTR_inquireDEFAULTFILE: + ffestb_local_.inquire.ix = FFESTP_inquireixDEFAULTFILE; + ffestb_local_.inquire.left = FALSE; + ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR; + break; + + case FFESTR_inquireDELIM: + ffestb_local_.inquire.ix = FFESTP_inquireixDELIM; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_inquireDIRECT: + ffestb_local_.inquire.ix = FFESTP_inquireixDIRECT; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_inquireERR: + ffestb_local_.inquire.ix = FFESTP_inquireixERR; + ffestb_local_.inquire.label = TRUE; + break; + + case FFESTR_inquireEXIST: + ffestb_local_.inquire.ix = FFESTP_inquireixEXIST; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILELOG; + break; + + case FFESTR_inquireFILE: + ffestb_local_.inquire.ix = FFESTP_inquireixFILE; + ffestb_local_.inquire.left = FALSE; + ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR; + break; + + case FFESTR_inquireFORM: + ffestb_local_.inquire.ix = FFESTP_inquireixFORM; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_inquireFORMATTED: + ffestb_local_.inquire.ix = FFESTP_inquireixFORMATTED; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_inquireIOLENGTH: + if (!ffestb_local_.inquire.may_be_iolength) + goto bad; /* :::::::::::::::::::: */ + ffestb_local_.inquire.ix = FFESTP_inquireixIOLENGTH; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILEINT; + break; + + case FFESTR_inquireIOSTAT: + ffestb_local_.inquire.ix = FFESTP_inquireixIOSTAT; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILEINT; + break; + + case FFESTR_inquireKEYED: + ffestb_local_.inquire.ix = FFESTP_inquireixKEYED; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR; + break; + + case FFESTR_inquireNAME: + ffestb_local_.inquire.ix = FFESTP_inquireixNAME; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR; + break; + + case FFESTR_inquireNAMED: + ffestb_local_.inquire.ix = FFESTP_inquireixNAMED; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILELOG; + break; + + case FFESTR_inquireNEXTREC: + ffestb_local_.inquire.ix = FFESTP_inquireixNEXTREC; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILEDFINT; + break; + + case FFESTR_inquireNUMBER: + ffestb_local_.inquire.ix = FFESTP_inquireixNUMBER; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILEINT; + break; + + case FFESTR_inquireOPENED: + ffestb_local_.inquire.ix = FFESTP_inquireixOPENED; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILELOG; + break; + + case FFESTR_inquireORGANIZATION: + ffestb_local_.inquire.ix = FFESTP_inquireixORGANIZATION; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR; + break; + + case FFESTR_inquirePAD: + ffestb_local_.inquire.ix = FFESTP_inquireixPAD; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_inquirePOSITION: + ffestb_local_.inquire.ix = FFESTP_inquireixPOSITION; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_inquireREAD: + ffestb_local_.inquire.ix = FFESTP_inquireixREAD; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_inquireREADWRITE: + ffestb_local_.inquire.ix = FFESTP_inquireixREADWRITE; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_inquireRECL: + ffestb_local_.inquire.ix = FFESTP_inquireixRECL; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILEINT; + break; + + case FFESTR_inquireRECORDTYPE: + ffestb_local_.inquire.ix = FFESTP_inquireixRECORDTYPE; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILECHAR; + break; + + case FFESTR_inquireSEQUENTIAL: + ffestb_local_.inquire.ix = FFESTP_inquireixSEQUENTIAL; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_inquireUNFORMATTED: + ffestb_local_.inquire.ix = FFESTP_inquireixUNFORMATTED; + ffestb_local_.inquire.left = TRUE; + ffestb_local_.inquire.context = FFEEXPR_contextFILEDFCHAR; + break; + + case FFESTR_inquireUNIT: + ffestb_local_.inquire.ix = FFESTP_inquireixUNIT; + ffestb_local_.inquire.left = FALSE; + ffestb_local_.inquire.context = FFEEXPR_contextFILENUM; + break; + + default: + goto bad; /* :::::::::::::::::::: */ + } + if (ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix] + .kw_or_val_present) + break; /* Can't specify a keyword twice! */ + ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix] + .kw_or_val_present = TRUE; + ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix] + .kw_present = TRUE; + ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix] + .value_present = FALSE; + ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].value_is_label + = ffestb_local_.inquire.label; + ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].kw + = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9235_; + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffestb_subr_kill_inquire_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9235_ -- "INQUIRE" OPEN_PAREN [external-file-unit COMMA] NAME + + return ffestb_R9235_; // to lexer + + Make sure EQUALS here, send next token to expression handler. */ + +static ffelexHandler +ffestb_R9235_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + ffesta_confirmed (); + if (ffestb_local_.inquire.label) + return (ffelexHandler) ffestb_R9237_; + if (ffestb_local_.inquire.left) + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + ffestb_local_.inquire.context, + (ffeexprCallback) ffestb_R9236_); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + ffestb_local_.inquire.context, + (ffeexprCallback) ffestb_R9236_); + + default: + break; + } + + ffestb_subr_kill_inquire_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9236_ -- "INQUIRE" OPEN_PAREN ... NAME EQUALS expr + + (ffestb_R9236_) // to expression handler + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_R9236_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (ffestb_local_.inquire.ix == FFESTP_inquireixIOLENGTH) + break; /* IOLENGTH=expr must be followed by + CLOSE_PAREN. */ + /* Fall through. */ + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].value_present + = TRUE; + ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].value + = ffelex_token_use (ft); + ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_R9234_; + if (ffestb_local_.inquire.ix == FFESTP_inquireixIOLENGTH) + return (ffelexHandler) ffestb_R92310_; + return (ffelexHandler) ffestb_R9239_; + + default: + break; + } + + ffestb_subr_kill_inquire_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9237_ -- "INQUIRE" OPEN_PAREN ... NAME EQUALS + + return ffestb_R9237_; // to lexer + + Handle NUMBER for label here. */ + +static ffelexHandler +ffestb_R9237_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].value_present + = TRUE; + ffestp_file.inquire.inquire_spec[ffestb_local_.inquire.ix].value + = ffelex_token_use (t); + return (ffelexHandler) ffestb_R9238_; + + default: + break; + } + + ffestb_subr_kill_inquire_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9238_ -- "INQUIRE" OPEN_PAREN ... NAME EQUALS NUMBER + + return ffestb_R9238_; // to lexer + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_R9238_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_R9234_; + + case FFELEX_typeCLOSE_PAREN: + return (ffelexHandler) ffestb_R9239_; + + default: + break; + } + + ffestb_subr_kill_inquire_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R9239_ -- "INQUIRE" OPEN_PAREN ... CLOSE_PAREN + + return ffestb_R9239_; // to lexer + + Handle EOS or SEMICOLON here. */ + +static ffelexHandler +ffestb_R9239_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R923A (); + ffestb_subr_kill_inquire_ (); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffestb_subr_kill_inquire_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R92310_ -- "INQUIRE(IOLENGTH=expr)" + + return ffestb_R92310_; // to lexer + + Make sure EOS or SEMICOLON not here; begin R923B processing and expect + output IO list. */ + +static ffelexHandler +ffestb_R92310_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + break; + + default: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R923B_start (); + ffestb_subr_kill_inquire_ (); + return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_R92311_))) + (t); + } + + ffestb_subr_kill_inquire_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R92311_ -- "INQUIRE(IOLENGTH=expr)" expr + + (ffestb_R92311_) // to expression handler + + Handle COMMA or EOS/SEMICOLON here. */ + +static ffelexHandler +ffestb_R92311_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + ffestc_R923B_item (expr, ft); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_R92311_); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + { + ffestc_R923B_item (expr, ft); + ffestc_R923B_finish (); + } + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R923B_finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "INQUIRE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V018 -- Parse the REWRITE statement + + return ffestb_V018; // to lexer + + Make sure the statement has a valid form for the REWRITE + statement. If it does, implement the statement. */ + +#if FFESTR_VXT +ffelexHandler +ffestb_V018 (ffelexToken t) +{ + ffestpRewriteIx ix; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstREWRITE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeNAME: + case FFELEX_typeNUMBER: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + for (ix = 0; ix < FFESTP_rewriteix; ++ix) + ffestp_file.rewrite.rewrite_spec[ix].kw_or_val_present = FALSE; + return (ffelexHandler) ffestb_V0181_; + } + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstREWRITE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlREWRITE) + goto bad_0; /* :::::::::::::::::::: */ + + for (ix = 0; ix < FFESTP_rewriteix; ++ix) + ffestp_file.rewrite.rewrite_spec[ix].kw_or_val_present = FALSE; + return (ffelexHandler) ffestb_V0181_; + } + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_V0181_ -- "REWRITE" OPEN_PAREN + + return ffestb_V0181_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_V0181_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_V0182_; + + default: + return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_V0183_))) + (t); + } +} + +/* ffestb_V0182_ -- "REWRITE" OPEN_PAREN NAME + + return ffestb_V0182_; // to lexer + + If EQUALS here, go to states that handle it. Else, send NAME and this + token thru expression handler. */ + +static ffelexHandler +ffestb_V0182_ (ffelexToken t) +{ + ffelexHandler next; + ffelexToken nt; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + nt = ffesta_tokens[1]; + next = (ffelexHandler) ffestb_V0187_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + nt = ffesta_tokens[1]; + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_V0183_))) + (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + } +} + +/* ffestb_V0183_ -- "REWRITE" OPEN_PAREN expr [CLOSE_PAREN] + + (ffestb_V0183_) // to expression handler + + Handle COMMA or EOS/SEMICOLON here. */ + +static ffelexHandler +ffestb_V0183_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT].kw_or_val_present + = TRUE; + ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT].kw_present = FALSE; + ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT].value_present = TRUE; + ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT].value_is_label + = FALSE; + ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT].value + = ffelex_token_use (ft); + ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixUNIT].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_V0184_; + return (ffelexHandler) ffestb_V01812_; + + default: + break; + } + + ffestb_subr_kill_rewrite_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0184_ -- "REWRITE" OPEN_PAREN expr COMMA + + return ffestb_V0184_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_V0184_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_V0185_; + + default: + return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEFORMAT, (ffeexprCallback) ffestb_V0186_))) + (t); + } +} + +/* ffestb_V0185_ -- "REWRITE" OPEN_PAREN expr COMMA NAME + + return ffestb_V0185_; // to lexer + + If EQUALS here, go to states that handle it. Else, send NAME and this + token thru expression handler. */ + +static ffelexHandler +ffestb_V0185_ (ffelexToken t) +{ + ffelexHandler next; + ffelexToken nt; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + nt = ffesta_tokens[1]; + next = (ffelexHandler) ffestb_V0187_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + nt = ffesta_tokens[1]; + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEFORMAT, (ffeexprCallback) ffestb_V0186_))) + (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + } +} + +/* ffestb_V0186_ -- "REWRITE" OPEN_PAREN expr COMMA expr + + (ffestb_V0186_) // to expression handler + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_V0186_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_or_val_present + = TRUE; + ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].kw_present = FALSE; + ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value_present = TRUE; + ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value_is_label + = (expr == NULL); + ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].value + = ffelex_token_use (ft); + ffestp_file.rewrite.rewrite_spec[FFESTP_rewriteixFMT].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_V0187_; + return (ffelexHandler) ffestb_V01812_; + + default: + break; + } + + ffestb_subr_kill_rewrite_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0187_ -- "REWRITE" OPEN_PAREN [external-file-unit COMMA [format + COMMA]] + + return ffestb_V0187_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_V0187_ (ffelexToken t) +{ + ffestrGenio kw; + + ffestb_local_.rewrite.label = FALSE; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + kw = ffestr_genio (t); + switch (kw) + { + case FFESTR_genioERR: + ffestb_local_.rewrite.ix = FFESTP_rewriteixERR; + ffestb_local_.rewrite.label = TRUE; + break; + + case FFESTR_genioFMT: + ffestb_local_.rewrite.ix = FFESTP_rewriteixFMT; + ffestb_local_.rewrite.left = FALSE; + ffestb_local_.rewrite.context = FFEEXPR_contextFILEFORMAT; + break; + + case FFESTR_genioIOSTAT: + ffestb_local_.rewrite.ix = FFESTP_rewriteixIOSTAT; + ffestb_local_.rewrite.left = TRUE; + ffestb_local_.rewrite.context = FFEEXPR_contextFILEINT; + break; + + case FFESTR_genioUNIT: + ffestb_local_.rewrite.ix = FFESTP_rewriteixUNIT; + ffestb_local_.rewrite.left = FALSE; + ffestb_local_.rewrite.context = FFEEXPR_contextFILENUM; + break; + + default: + goto bad; /* :::::::::::::::::::: */ + } + if (ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix] + .kw_or_val_present) + break; /* Can't specify a keyword twice! */ + ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix] + .kw_or_val_present = TRUE; + ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix] + .kw_present = TRUE; + ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix] + .value_present = FALSE; + ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix].value_is_label + = ffestb_local_.rewrite.label; + ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix].kw + = ffelex_token_use (t); + return (ffelexHandler) ffestb_V0188_; + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffestb_subr_kill_rewrite_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0188_ -- "REWRITE" OPEN_PAREN [external-file-unit COMMA [format + COMMA]] NAME + + return ffestb_V0188_; // to lexer + + Make sure EQUALS here, send next token to expression handler. */ + +static ffelexHandler +ffestb_V0188_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + ffesta_confirmed (); + if (ffestb_local_.rewrite.label) + return (ffelexHandler) ffestb_V01810_; + if (ffestb_local_.rewrite.left) + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + ffestb_local_.rewrite.context, + (ffeexprCallback) ffestb_V0189_); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + ffestb_local_.rewrite.context, + (ffeexprCallback) ffestb_V0189_); + + default: + break; + } + + ffestb_subr_kill_rewrite_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0189_ -- "REWRITE" OPEN_PAREN ... NAME EQUALS expr + + (ffestb_V0189_) // to expression handler + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_V0189_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + if (ffestb_local_.rewrite.context == FFEEXPR_contextFILEFORMAT) + ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix] + .value_is_label = TRUE; + else + break; + ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix].value_present + = TRUE; + ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix].value + = ffelex_token_use (ft); + ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_V0187_; + return (ffelexHandler) ffestb_V01812_; + + default: + break; + } + + ffestb_subr_kill_rewrite_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V01810_ -- "REWRITE" OPEN_PAREN ... NAME EQUALS + + return ffestb_V01810_; // to lexer + + Handle NUMBER for label here. */ + +static ffelexHandler +ffestb_V01810_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix].value_present + = TRUE; + ffestp_file.rewrite.rewrite_spec[ffestb_local_.rewrite.ix].value + = ffelex_token_use (t); + return (ffelexHandler) ffestb_V01811_; + + default: + break; + } + + ffestb_subr_kill_rewrite_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V01811_ -- "REWRITE" OPEN_PAREN ... NAME EQUALS NUMBER + + return ffestb_V01811_; // to lexer + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_V01811_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_V0187_; + + case FFELEX_typeCLOSE_PAREN: + return (ffelexHandler) ffestb_V01812_; + + default: + break; + } + + ffestb_subr_kill_rewrite_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V01812_ -- "REWRITE" OPEN_PAREN ... CLOSE_PAREN + + return ffestb_V01812_; // to lexer + + Handle EOS or SEMICOLON here. */ + +static ffelexHandler +ffestb_V01812_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + ffestc_V018_start (); + ffestc_V018_finish (); + } + ffestb_subr_kill_rewrite_ (); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeNAME: + case FFELEX_typeOPEN_PAREN: + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_V018_start (); + ffestb_subr_kill_rewrite_ (); + + /* EXTENSION: Allow an optional preceding COMMA here if not pedantic. + (f2c provides this extension, as do other compilers, supposedly.) */ + + if (!ffe_is_pedantic () && (ffelex_token_type (t) == FFELEX_typeCOMMA)) + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_V01813_); + + return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_V01813_))) + (t); + + default: + break; + } + + ffestb_subr_kill_rewrite_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V01813_ -- "REWRITE(...)" expr + + (ffestb_V01813_) // to expression handler + + Handle COMMA or EOS/SEMICOLON here. */ + +static ffelexHandler +ffestb_V01813_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + ffestc_V018_item (expr, ft); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_V01813_); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + { + ffestc_V018_item (expr, ft); + ffestc_V018_finish (); + } + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_V018_finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "REWRITE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V019 -- Parse the ACCEPT statement + + return ffestb_V019; // to lexer + + Make sure the statement has a valid form for the ACCEPT + statement. If it does, implement the statement. */ + +ffelexHandler +ffestb_V019 (ffelexToken t) +{ + ffelexHandler next; + ffestpAcceptIx ix; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstACCEPT) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + case FFELEX_typeCOLON: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + case FFELEX_typeNUMBER: + ffesta_confirmed (); + break; + + default: + break; + } + + for (ix = 0; ix < FFESTP_acceptix; ++ix) + ffestp_file.accept.accept_spec[ix].kw_or_val_present = FALSE; + return (ffelexHandler) (*((ffelexHandler) + ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_V0191_))) + (t); + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstACCEPT) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlACCEPT) + break; + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + case FFELEX_typeCOLON: + goto bad_1; /* :::::::::::::::::::: */ + + default: + break; + } + for (ix = 0; ix < FFESTP_acceptix; ++ix) + ffestp_file.accept.accept_spec[ix].kw_or_val_present = FALSE; + next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_V0191_); + next = (ffelexHandler) ffelex_splice_tokens (next, ffesta_tokens[0], + FFESTR_firstlACCEPT); + if (next == NULL) + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + return (ffelexHandler) (*next) (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ACCEPT", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ACCEPT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_V0191_ -- "ACCEPT" expr + + (ffestb_V0191_) // to expression handler + + Make sure the next token is a COMMA or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_V0191_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + ffesta_confirmed (); + ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT].kw_or_val_present + = TRUE; + ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT].kw_present = FALSE; + ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT].value_present = TRUE; + ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT].value_is_label + = (expr == NULL); + ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT].value + = ffelex_token_use (ft); + ffestp_file.accept.accept_spec[FFESTP_acceptixFORMAT].u.expr = expr; + if (!ffesta_is_inhibited ()) + ffestc_V019_start (); + ffestb_subr_kill_accept_ (); + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextIOLIST, + (ffeexprCallback) ffestb_V0192_); + if (!ffesta_is_inhibited ()) + ffestc_V019_finish (); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffestb_subr_kill_accept_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ACCEPT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0192_ -- "ACCEPT" expr COMMA expr + + (ffestb_V0192_) // to expression handler + + Handle COMMA or EOS/SEMICOLON here. */ + +static ffelexHandler +ffestb_V0192_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + ffestc_V019_item (expr, ft); + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextIOLIST, + (ffeexprCallback) ffestb_V0192_); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + { + ffestc_V019_item (expr, ft); + ffestc_V019_finish (); + } + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_V019_finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "ACCEPT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_V020 -- Parse the TYPE statement + + return ffestb_V020; // to lexer + + Make sure the statement has a valid form for the TYPE + statement. If it does, implement the statement. */ + +ffelexHandler +ffestb_V020 (ffelexToken t) +{ + ffeTokenLength i; + char *p; + ffelexHandler next; + ffestpTypeIx ix; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstTYPE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOLONCOLON: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + case FFELEX_typeCOLON: + case FFELEX_typeCOMMA: /* Because "TYPE,PUBLIC::A" is ambiguous with + '90. */ + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNUMBER: + ffesta_confirmed (); + break; + + case FFELEX_typeNAME: /* Because TYPE A is ambiguous with '90. */ + default: + break; + } + + for (ix = 0; ix < FFESTP_typeix; ++ix) + ffestp_file.type.type_spec[ix].kw_or_val_present = FALSE; + return (ffelexHandler) (*((ffelexHandler) + ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_V0201_))) + (t); + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstTYPE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlTYPE) + break; + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + if (ffelex_token_length (ffesta_tokens[0]) == FFESTR_firstlTYPE) + break; /* Else might be assignment/stmtfuncdef. */ + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + case FFELEX_typeCOLON: + goto bad_1; /* :::::::::::::::::::: */ + + default: + break; + } + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlTYPE); + if (isdigit (*p)) + ffesta_confirmed (); /* Else might be '90 TYPE statement. */ + for (ix = 0; ix < FFESTP_typeix; ++ix) + ffestp_file.type.type_spec[ix].kw_or_val_present = FALSE; + next = (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILEFORMATNML, (ffeexprCallback) ffestb_V0201_); + next = (ffelexHandler) ffelex_splice_tokens (next, ffesta_tokens[0], + FFESTR_firstlTYPE); + if (next == NULL) + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); + return (ffelexHandler) (*next) (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE I/O", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE I/O", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_V0201_ -- "TYPE" expr + + (ffestb_V0201_) // to expression handler + + Make sure the next token is a COMMA or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_V0201_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + bool comma = TRUE; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffe_is_vxt () && (expr != NULL) + && (ffebld_op (expr) == FFEBLD_opSYMTER)) + break; + comma = FALSE; + /* Fall through. */ + case FFELEX_typeCOMMA: + if (!ffe_is_vxt () && comma && (expr != NULL) + && (ffebld_op (expr) == FFEBLD_opPAREN) + && (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)) + break; + ffesta_confirmed (); + ffestp_file.type.type_spec[FFESTP_typeixFORMAT].kw_or_val_present + = TRUE; + ffestp_file.type.type_spec[FFESTP_typeixFORMAT].kw_present = FALSE; + ffestp_file.type.type_spec[FFESTP_typeixFORMAT].value_present = TRUE; + ffestp_file.type.type_spec[FFESTP_typeixFORMAT].value_is_label + = (expr == NULL); + ffestp_file.type.type_spec[FFESTP_typeixFORMAT].value + = ffelex_token_use (ft); + ffestp_file.type.type_spec[FFESTP_typeixFORMAT].u.expr = expr; + if (!ffesta_is_inhibited ()) + ffestc_V020_start (); + ffestb_subr_kill_type_ (); + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_V0202_); + if (!ffesta_is_inhibited ()) + ffestc_V020_finish (); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffestb_subr_kill_type_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE I/O", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0202_ -- "TYPE" expr COMMA expr + + (ffestb_V0202_) // to expression handler + + Handle COMMA or EOS/SEMICOLON here. */ + +static ffelexHandler +ffestb_V0202_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + ffestc_V020_item (expr, ft); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextIOLIST, (ffeexprCallback) ffestb_V0202_); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + { + ffestc_V020_item (expr, ft); + ffestc_V020_finish (); + } + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_V020_finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "TYPE I/O", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V021 -- Parse a DELETE statement + + return ffestb_V021; // to lexer + + Make sure the statement has a valid form for a DELETE statement. + If it does, implement the statement. */ + +#if FFESTR_VXT +ffelexHandler +ffestb_V021 (ffelexToken t) +{ + ffestpDeleteIx ix; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstDELETE) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstDELETE) + goto bad_0; /* :::::::::::::::::::: */ + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlDELETE) + goto bad_0; /* :::::::::::::::::::: */ + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + for (ix = 0; ix < FFESTP_deleteix; ++ix) + ffestp_file.delete.delete_spec[ix].kw_or_val_present = FALSE; + + return (ffelexHandler) ffestb_V0211_; + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DELETE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DELETE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_V0211_ -- "DELETE" OPEN_PAREN + + return ffestb_V0211_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_V0211_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_V0212_; + + default: + return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_V0213_))) + (t); + } +} + +/* ffestb_V0212_ -- "DELETE" OPEN_PAREN NAME + + return ffestb_V0212_; // to lexer + + If EQUALS here, go to states that handle it. Else, send NAME and this + token thru expression handler. */ + +static ffelexHandler +ffestb_V0212_ (ffelexToken t) +{ + ffelexHandler next; + ffelexToken nt; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + nt = ffesta_tokens[1]; + next = (ffelexHandler) ffestb_V0214_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_V0213_))) + (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) (*next) (t); + } +} + +/* ffestb_V0213_ -- "DELETE" OPEN_PAREN expr + + (ffestb_V0213_) // to expression handler + + Handle COMMA or DELETE_PAREN here. */ + +static ffelexHandler +ffestb_V0213_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT].kw_or_val_present + = TRUE; + ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT].kw_present = FALSE; + ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT].value_present = TRUE; + ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT].value_is_label + = FALSE; + ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT].value + = ffelex_token_use (ft); + ffestp_file.delete.delete_spec[FFESTP_deleteixUNIT].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_V0214_; + return (ffelexHandler) ffestb_V0219_; + + default: + break; + } + + ffestb_subr_kill_delete_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DELETE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0214_ -- "DELETE" OPEN_PAREN [external-file-unit COMMA] + + return ffestb_V0214_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_V0214_ (ffelexToken t) +{ + ffestrGenio kw; + + ffestb_local_.delete.label = FALSE; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + kw = ffestr_genio (t); + switch (kw) + { + case FFESTR_genioERR: + ffestb_local_.delete.ix = FFESTP_deleteixERR; + ffestb_local_.delete.label = TRUE; + break; + + case FFESTR_genioIOSTAT: + ffestb_local_.delete.ix = FFESTP_deleteixIOSTAT; + ffestb_local_.delete.left = TRUE; + ffestb_local_.delete.context = FFEEXPR_contextFILEINT; + break; + + case FFESTR_genioREC: + ffestb_local_.delete.ix = FFESTP_deleteixREC; + ffestb_local_.delete.left = FALSE; + ffestb_local_.delete.context = FFEEXPR_contextFILENUM; + break; + + case FFESTR_genioUNIT: + ffestb_local_.delete.ix = FFESTP_deleteixUNIT; + ffestb_local_.delete.left = FALSE; + ffestb_local_.delete.context = FFEEXPR_contextFILENUM; + break; + + default: + goto bad; /* :::::::::::::::::::: */ + } + if (ffestp_file.delete.delete_spec[ffestb_local_.delete.ix] + .kw_or_val_present) + break; /* Can't specify a keyword twice! */ + ffestp_file.delete.delete_spec[ffestb_local_.delete.ix] + .kw_or_val_present = TRUE; + ffestp_file.delete.delete_spec[ffestb_local_.delete.ix] + .kw_present = TRUE; + ffestp_file.delete.delete_spec[ffestb_local_.delete.ix] + .value_present = FALSE; + ffestp_file.delete.delete_spec[ffestb_local_.delete.ix].value_is_label + = ffestb_local_.delete.label; + ffestp_file.delete.delete_spec[ffestb_local_.delete.ix].kw + = ffelex_token_use (t); + return (ffelexHandler) ffestb_V0215_; + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffestb_subr_kill_delete_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DELETE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0215_ -- "DELETE" OPEN_PAREN [external-file-unit COMMA] NAME + + return ffestb_V0215_; // to lexer + + Make sure EQUALS here, send next token to expression handler. */ + +static ffelexHandler +ffestb_V0215_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + ffesta_confirmed (); + if (ffestb_local_.delete.label) + return (ffelexHandler) ffestb_V0217_; + if (ffestb_local_.delete.left) + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + ffestb_local_.delete.context, + (ffeexprCallback) ffestb_V0216_); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + ffestb_local_.delete.context, (ffeexprCallback) ffestb_V0216_); + + default: + break; + } + + ffestb_subr_kill_delete_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DELETE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0216_ -- "DELETE" OPEN_PAREN ... NAME EQUALS expr + + (ffestb_V0216_) // to expression handler + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_V0216_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestp_file.delete.delete_spec[ffestb_local_.delete.ix].value_present + = TRUE; + ffestp_file.delete.delete_spec[ffestb_local_.delete.ix].value + = ffelex_token_use (ft); + ffestp_file.delete.delete_spec[ffestb_local_.delete.ix].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_V0214_; + return (ffelexHandler) ffestb_V0219_; + + default: + break; + } + + ffestb_subr_kill_delete_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DELETE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0217_ -- "DELETE" OPEN_PAREN ... NAME EQUALS + + return ffestb_V0217_; // to lexer + + Handle NUMBER for label here. */ + +static ffelexHandler +ffestb_V0217_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + ffestp_file.delete.delete_spec[ffestb_local_.delete.ix].value_present + = TRUE; + ffestp_file.delete.delete_spec[ffestb_local_.delete.ix].value + = ffelex_token_use (t); + return (ffelexHandler) ffestb_V0218_; + + default: + break; + } + + ffestb_subr_kill_delete_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DELETE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0218_ -- "DELETE" OPEN_PAREN ... NAME EQUALS NUMBER + + return ffestb_V0218_; // to lexer + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_V0218_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_V0214_; + + case FFELEX_typeCLOSE_PAREN: + return (ffelexHandler) ffestb_V0219_; + + default: + break; + } + + ffestb_subr_kill_delete_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DELETE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0219_ -- "DELETE" OPEN_PAREN ... CLOSE_PAREN + + return ffestb_V0219_; // to lexer + + Handle EOS or SEMICOLON here. */ + +static ffelexHandler +ffestb_V0219_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_V021 (); + ffestb_subr_kill_delete_ (); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffestb_subr_kill_delete_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "DELETE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V026 -- Parse a FIND statement + + return ffestb_V026; // to lexer + + Make sure the statement has a valid form for a FIND statement. + If it does, implement the statement. */ + +ffelexHandler +ffestb_V026 (ffelexToken t) +{ + ffestpFindIx ix; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstFIND) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstFIND) + goto bad_0; /* :::::::::::::::::::: */ + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlFIND) + goto bad_0; /* :::::::::::::::::::: */ + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + for (ix = 0; ix < FFESTP_findix; ++ix) + ffestp_file.find.find_spec[ix].kw_or_val_present = FALSE; + + return (ffelexHandler) ffestb_V0261_; + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FIND", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FIND", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_V0261_ -- "FIND" OPEN_PAREN + + return ffestb_V0261_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_V0261_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_V0262_; + + default: + return (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_V0263_))) + (t); + } +} + +/* ffestb_V0262_ -- "FIND" OPEN_PAREN NAME + + return ffestb_V0262_; // to lexer + + If EQUALS here, go to states that handle it. Else, send NAME and this + token thru expression handler. */ + +static ffelexHandler +ffestb_V0262_ (ffelexToken t) +{ + ffelexHandler next; + ffelexToken nt; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + nt = ffesta_tokens[1]; + next = (ffelexHandler) ffestb_V0264_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + next = (ffelexHandler) (*((ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextFILENUM, (ffeexprCallback) ffestb_V0263_))) + (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) (*next) (t); + } +} + +/* ffestb_V0263_ -- "FIND" OPEN_PAREN expr + + (ffestb_V0263_) // to expression handler + + Handle COMMA or FIND_PAREN here. */ + +static ffelexHandler +ffestb_V0263_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestp_file.find.find_spec[FFESTP_findixUNIT].kw_or_val_present + = TRUE; + ffestp_file.find.find_spec[FFESTP_findixUNIT].kw_present = FALSE; + ffestp_file.find.find_spec[FFESTP_findixUNIT].value_present = TRUE; + ffestp_file.find.find_spec[FFESTP_findixUNIT].value_is_label + = FALSE; + ffestp_file.find.find_spec[FFESTP_findixUNIT].value + = ffelex_token_use (ft); + ffestp_file.find.find_spec[FFESTP_findixUNIT].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_V0264_; + return (ffelexHandler) ffestb_V0269_; + + default: + break; + } + + ffestb_subr_kill_find_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FIND", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0264_ -- "FIND" OPEN_PAREN [external-file-unit COMMA] + + return ffestb_V0264_; // to lexer + + Handle expr construct (not NAME=expr construct) here. */ + +static ffelexHandler +ffestb_V0264_ (ffelexToken t) +{ + ffestrGenio kw; + + ffestb_local_.find.label = FALSE; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + kw = ffestr_genio (t); + switch (kw) + { + case FFESTR_genioERR: + ffestb_local_.find.ix = FFESTP_findixERR; + ffestb_local_.find.label = TRUE; + break; + + case FFESTR_genioIOSTAT: + ffestb_local_.find.ix = FFESTP_findixIOSTAT; + ffestb_local_.find.left = TRUE; + ffestb_local_.find.context = FFEEXPR_contextFILEINT; + break; + + case FFESTR_genioREC: + ffestb_local_.find.ix = FFESTP_findixREC; + ffestb_local_.find.left = FALSE; + ffestb_local_.find.context = FFEEXPR_contextFILENUM; + break; + + case FFESTR_genioUNIT: + ffestb_local_.find.ix = FFESTP_findixUNIT; + ffestb_local_.find.left = FALSE; + ffestb_local_.find.context = FFEEXPR_contextFILENUM; + break; + + default: + goto bad; /* :::::::::::::::::::: */ + } + if (ffestp_file.find.find_spec[ffestb_local_.find.ix] + .kw_or_val_present) + break; /* Can't specify a keyword twice! */ + ffestp_file.find.find_spec[ffestb_local_.find.ix] + .kw_or_val_present = TRUE; + ffestp_file.find.find_spec[ffestb_local_.find.ix] + .kw_present = TRUE; + ffestp_file.find.find_spec[ffestb_local_.find.ix] + .value_present = FALSE; + ffestp_file.find.find_spec[ffestb_local_.find.ix].value_is_label + = ffestb_local_.find.label; + ffestp_file.find.find_spec[ffestb_local_.find.ix].kw + = ffelex_token_use (t); + return (ffelexHandler) ffestb_V0265_; + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffestb_subr_kill_find_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FIND", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0265_ -- "FIND" OPEN_PAREN [external-file-unit COMMA] NAME + + return ffestb_V0265_; // to lexer + + Make sure EQUALS here, send next token to expression handler. */ + +static ffelexHandler +ffestb_V0265_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + ffesta_confirmed (); + if (ffestb_local_.find.label) + return (ffelexHandler) ffestb_V0267_; + if (ffestb_local_.find.left) + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + ffestb_local_.find.context, + (ffeexprCallback) ffestb_V0266_); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + ffestb_local_.find.context, + (ffeexprCallback) ffestb_V0266_); + + default: + break; + } + + ffestb_subr_kill_find_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FIND", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0266_ -- "FIND" OPEN_PAREN ... NAME EQUALS expr + + (ffestb_V0266_) // to expression handler + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_V0266_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestp_file.find.find_spec[ffestb_local_.find.ix].value_present + = TRUE; + ffestp_file.find.find_spec[ffestb_local_.find.ix].value + = ffelex_token_use (ft); + ffestp_file.find.find_spec[ffestb_local_.find.ix].u.expr = expr; + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_V0264_; + return (ffelexHandler) ffestb_V0269_; + + default: + break; + } + + ffestb_subr_kill_find_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FIND", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0267_ -- "FIND" OPEN_PAREN ... NAME EQUALS + + return ffestb_V0267_; // to lexer + + Handle NUMBER for label here. */ + +static ffelexHandler +ffestb_V0267_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + ffestp_file.find.find_spec[ffestb_local_.find.ix].value_present + = TRUE; + ffestp_file.find.find_spec[ffestb_local_.find.ix].value + = ffelex_token_use (t); + return (ffelexHandler) ffestb_V0268_; + + default: + break; + } + + ffestb_subr_kill_find_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FIND", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0268_ -- "FIND" OPEN_PAREN ... NAME EQUALS NUMBER + + return ffestb_V0268_; // to lexer + + Handle COMMA or CLOSE_PAREN here. */ + +static ffelexHandler +ffestb_V0268_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_V0264_; + + case FFELEX_typeCLOSE_PAREN: + return (ffelexHandler) ffestb_V0269_; + + default: + break; + } + + ffestb_subr_kill_find_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FIND", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0269_ -- "FIND" OPEN_PAREN ... CLOSE_PAREN + + return ffestb_V0269_; // to lexer + + Handle EOS or SEMICOLON here. */ + +static ffelexHandler +ffestb_V0269_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_V026 (); + ffestb_subr_kill_find_ (); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffestb_subr_kill_find_ (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FIND", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_dimlist -- Parse the ALLOCATABLE/POINTER/TARGET statement + + return ffestb_dimlist; // to lexer + + Make sure the statement has a valid form for the ALLOCATABLE/POINTER/ + TARGET statement. If it does, implement the statement. */ + +#if FFESTR_F90 +ffelexHandler +ffestb_dimlist (ffelexToken t) +{ + ffeTokenLength i; + char *p; + ffelexToken nt; + ffelexHandler next; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + switch (ffesta_first_kw) + { + case FFESTR_firstALLOCATABLE: + ffestc_R525_start (); + break; + + case FFESTR_firstPOINTER: + ffestc_R526_start (); + break; + + case FFESTR_firstTARGET: + ffestc_R527_start (); + break; + + default: + assert (FALSE); + } + } + ffestb_local_.dimlist.started = TRUE; + return (ffelexHandler) ffestb_dimlist1_; + + case FFELEX_typeNAME: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + switch (ffesta_first_kw) + { + case FFESTR_firstALLOCATABLE: + ffestc_R525_start (); + break; + + case FFESTR_firstPOINTER: + ffestc_R526_start (); + break; + + case FFESTR_firstTARGET: + ffestc_R527_start (); + break; + + default: + assert (FALSE); + } + } + ffestb_local_.dimlist.started = TRUE; + return (ffelexHandler) ffestb_dimlist1_ (t); + } + + case FFELEX_typeNAMES: + p = ffelex_token_text (ffesta_tokens[0]) + (i = ffestb_args.dimlist.len); + switch (ffelex_token_type (t)) + { + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + if (!ffesta_is_inhibited ()) + { + switch (ffesta_first_kw) + { + case FFESTR_firstALLOCATABLE: + ffestc_R525_start (); + break; + + case FFESTR_firstPOINTER: + ffestc_R526_start (); + break; + + case FFESTR_firstTARGET: + ffestc_R527_start (); + break; + + default: + assert (FALSE); + } + } + ffestb_local_.dimlist.started = TRUE; + next = (ffelexHandler) ffestb_dimlist1_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); + if (*p != '\0') + goto bad_i; /* :::::::::::::::::::: */ + if (!ffesta_is_inhibited ()) + { + switch (ffesta_first_kw) + { + case FFESTR_firstALLOCATABLE: + ffestc_R525_start (); + break; + + case FFESTR_firstPOINTER: + ffestc_R526_start (); + break; + + case FFESTR_firstTARGET: + ffestc_R527_start (); + break; + + default: + assert (FALSE); + } + } + ffestb_local_.dimlist.started = TRUE; + return (ffelexHandler) ffestb_dimlist1_; + + case FFELEX_typeOPEN_PAREN: + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + ffestb_local_.dimlist.started = FALSE; + next = (ffelexHandler) ffestb_dimlist1_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + } + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.dimlist.badname, ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.dimlist.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, ffestb_args.dimlist.badname, ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_dimlist1_ -- "ALLOCATABLE/POINTER/TARGET" [COLONCOLON] + + return ffestb_dimlist1_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_dimlist1_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_dimlist2_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.dimlist.badname, t); + break; + } + + if (!ffesta_is_inhibited ()) + { + switch (ffesta_first_kw) + { + case FFESTR_firstALLOCATABLE: + ffestc_R525_finish (); + break; + + case FFESTR_firstPOINTER: + ffestc_R526_finish (); + break; + + case FFESTR_firstTARGET: + ffestc_R527_finish (); + break; + + default: + assert (FALSE); + } + } + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_dimlist2_ -- "ALLOCATABLE/POINTER/TARGET" ... NAME + + return ffestb_dimlist2_; // to lexer + + Handle OPEN_PAREN. */ + +static ffelexHandler +ffestb_dimlist2_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + ffestb_subrargs_.dim_list.dims = ffestt_dimlist_create (); + ffestb_subrargs_.dim_list.handler = (ffelexHandler) ffestb_dimlist3_; + ffestb_subrargs_.dim_list.pool = ffesta_output_pool; + ffestb_subrargs_.dim_list.ctx = FFEEXPR_contextDIMLIST; +#ifdef FFECOM_dimensionsMAX + ffestb_subrargs_.dim_list.ndims = 0; +#endif + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextDIMLIST, (ffeexprCallback) ffestb_subr_dimlist_); + + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + if (!ffestb_local_.dimlist.started) + { + switch (ffesta_first_kw) + { + case FFESTR_firstALLOCATABLE: + ffestc_R525_start (); + break; + + case FFESTR_firstPOINTER: + ffestc_R526_start (); + break; + + case FFESTR_firstTARGET: + ffestc_R527_start (); + break; + + default: + assert (FALSE); + } + ffestb_local_.dimlist.started = TRUE; + } + switch (ffesta_first_kw) + { + case FFESTR_firstALLOCATABLE: + ffestc_R525_item (ffesta_tokens[1], NULL); + break; + + case FFESTR_firstPOINTER: + ffestc_R526_item (ffesta_tokens[1], NULL); + break; + + case FFESTR_firstTARGET: + ffestc_R527_item (ffesta_tokens[1], NULL); + break; + + default: + assert (FALSE); + } + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_dimlist4_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + if (!ffestb_local_.dimlist.started) + { + switch (ffesta_first_kw) + { + case FFESTR_firstALLOCATABLE: + ffestc_R525_start (); + break; + + case FFESTR_firstPOINTER: + ffestc_R526_start (); + break; + + case FFESTR_firstTARGET: + ffestc_R527_start (); + break; + + default: + assert (FALSE); + } + } + switch (ffesta_first_kw) + { + case FFESTR_firstALLOCATABLE: + ffestc_R525_item (ffesta_tokens[1], NULL); + ffestc_R525_finish (); + break; + + case FFESTR_firstPOINTER: + ffestc_R526_item (ffesta_tokens[1], NULL); + ffestc_R526_finish (); + break; + + case FFESTR_firstTARGET: + ffestc_R527_item (ffesta_tokens[1], NULL); + ffestc_R527_finish (); + break; + + default: + assert (FALSE); + } + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.dimlist.badname, t); + break; + } + + if (!ffesta_is_inhibited ()) + { + switch (ffesta_first_kw) + { + case FFESTR_firstALLOCATABLE: + ffestc_R525_finish (); + break; + + case FFESTR_firstPOINTER: + ffestc_R526_finish (); + break; + + case FFESTR_firstTARGET: + ffestc_R527_finish (); + break; + + default: + assert (FALSE); + } + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_dimlist3_ -- "ALLOCATABLE/POINTER/TARGET" ... NAME OPEN_PAREN + dimlist CLOSE_PAREN + + return ffestb_dimlist3_; // to lexer + + Handle COMMA or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_dimlist3_ (ffelexToken t) +{ + if (!ffestb_subrargs_.dim_list.ok) + goto bad; /* :::::::::::::::::::: */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + if (!ffestb_local_.dimlist.started) + { + switch (ffesta_first_kw) + { + case FFESTR_firstALLOCATABLE: + ffestc_R525_start (); + break; + + case FFESTR_firstPOINTER: + ffestc_R526_start (); + break; + + case FFESTR_firstTARGET: + ffestc_R527_start (); + break; + + default: + assert (FALSE); + } + ffestb_local_.dimlist.started = TRUE; + } + switch (ffesta_first_kw) + { + case FFESTR_firstALLOCATABLE: + ffestc_R525_item (ffesta_tokens[1], + ffestb_subrargs_.dim_list.dims); + break; + + case FFESTR_firstPOINTER: + ffestc_R526_item (ffesta_tokens[1], + ffestb_subrargs_.dim_list.dims); + break; + + case FFESTR_firstTARGET: + ffestc_R527_item (ffesta_tokens[1], + ffestb_subrargs_.dim_list.dims); + break; + + default: + assert (FALSE); + } + } + ffelex_token_kill (ffesta_tokens[1]); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + return (ffelexHandler) ffestb_dimlist4_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + if (!ffestb_local_.dimlist.started) + { + switch (ffesta_first_kw) + { + case FFESTR_firstALLOCATABLE: + ffestc_R525_start (); + break; + + case FFESTR_firstPOINTER: + ffestc_R526_start (); + break; + + case FFESTR_firstTARGET: + ffestc_R527_start (); + break; + + default: + assert (FALSE); + } + } + switch (ffesta_first_kw) + { + case FFESTR_firstALLOCATABLE: + ffestc_R525_item (ffesta_tokens[1], + ffestb_subrargs_.dim_list.dims); + ffestc_R525_finish (); + break; + + case FFESTR_firstPOINTER: + ffestc_R526_item (ffesta_tokens[1], + ffestb_subrargs_.dim_list.dims); + ffestc_R526_finish (); + break; + + case FFESTR_firstTARGET: + ffestc_R527_item (ffesta_tokens[1], + ffestb_subrargs_.dim_list.dims); + ffestc_R527_finish (); + break; + + default: + assert (FALSE); + } + } + ffelex_token_kill (ffesta_tokens[1]); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.dimlist.badname, t); + if (ffestb_local_.dimlist.started && !ffesta_is_inhibited ()) + { + switch (ffesta_first_kw) + { + case FFESTR_firstALLOCATABLE: + ffestc_R525_finish (); + break; + + case FFESTR_firstPOINTER: + ffestc_R526_finish (); + break; + + case FFESTR_firstTARGET: + ffestc_R527_finish (); + break; + + default: + assert (FALSE); + } + } + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_dimlist4_ -- "ALLOCATABLE/POINTER/TARGET" ... COMMA + + return ffestb_dimlist4_; // to lexer + + Make sure we don't have EOS or SEMICOLON. */ + +static ffelexHandler +ffestb_dimlist4_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + { + switch (ffesta_first_kw) + { + case FFESTR_firstALLOCATABLE: + ffestc_R525_finish (); + break; + + case FFESTR_firstPOINTER: + ffestc_R526_finish (); + break; + + case FFESTR_firstTARGET: + ffestc_R527_finish (); + break; + + default: + assert (FALSE); + } + } + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.dimlist.badname, t); + return (ffelexHandler) ffesta_zero (t); + + default: + return (ffelexHandler) ffestb_dimlist1_ (t); + } +} + +#endif +/* ffestb_dummy -- Parse an ENTRY/FUNCTION/SUBROUTINE statement + + return ffestb_dummy; // to lexer + + Make sure the statement has a valid form for an ENTRY/FUNCTION/SUBROUTINE + statement. If it does, implement the statement. */ + +ffelexHandler +ffestb_dummy (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + break; + } + + ffesta_confirmed (); + ffesta_tokens[1] = ffelex_token_use (t); + ffestb_local_.decl.recursive = NULL; + ffestb_local_.dummy.badname = ffestb_args.dummy.badname; + ffestb_local_.dummy.is_subr = ffestb_args.dummy.is_subr; + ffestb_local_.dummy.first_kw = ffesta_first_kw; + return (ffelexHandler) ffestb_dummy1_; + + case FFELEX_typeNAMES: + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + break; + + case FFELEX_typeOPEN_PAREN: + break; + } + p = ffelex_token_text (ffesta_tokens[0]) + (i = ffestb_args.dummy.len); + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffesta_tokens[1] + = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + ffestb_local_.decl.recursive = NULL; + ffestb_local_.dummy.badname = ffestb_args.dummy.badname; + ffestb_local_.dummy.is_subr = ffestb_args.dummy.is_subr; + ffestb_local_.dummy.first_kw = ffesta_first_kw; + return (ffelexHandler) ffestb_dummy1_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.dummy.badname, ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.dummy.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, ffestb_args.dummy.badname, ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_dummy1_ -- "ENTRY/FUNCTION/SUBROUTINE" NAME + + return ffestb_dummy1_; // to lexer + + Make sure the next token is an EOS, SEMICOLON, or OPEN_PAREN. In the + former case, just implement a null arg list, else get the arg list and + then implement. */ + +static ffelexHandler +ffestb_dummy1_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (ffestb_local_.dummy.first_kw == FFESTR_firstFUNCTION) + { + ffesta_confirmed (); /* Later, not if typename w/o RECURSIVE. */ + break; /* Produce an error message, need that open + paren. */ + } + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { /* Pretend as though we got a truly NULL + list. */ + ffestb_subrargs_.name_list.args = NULL; + ffestb_subrargs_.name_list.ok = TRUE; + ffestb_subrargs_.name_list.close_paren = ffelex_token_use (t); + return (ffelexHandler) ffestb_dummy2_ (t); + } + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeOPEN_PAREN: + ffestb_subrargs_.name_list.args = ffestt_tokenlist_create (); + ffestb_subrargs_.name_list.handler = (ffelexHandler) ffestb_dummy2_; + ffestb_subrargs_.name_list.is_subr = ffestb_local_.dummy.is_subr; + ffestb_subrargs_.name_list.names = FALSE; + return (ffelexHandler) ffestb_subr_name_list_; + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_local_.dummy.badname, t); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_dummy2_ -- NAME OPEN_PAREN arg-list CLOSE_PAREN + + return ffestb_dummy2_; // to lexer + + Make sure the statement has a valid form for a dummy-def statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_dummy2_ (ffelexToken t) +{ + if (!ffestb_subrargs_.name_list.ok) + goto bad; /* :::::::::::::::::::: */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + switch (ffestb_local_.dummy.first_kw) + { + case FFESTR_firstFUNCTION: + ffestc_R1219 (ffesta_tokens[1], ffestb_subrargs_.name_list.args, + ffestb_subrargs_.name_list.close_paren, FFESTP_typeNone, + NULL, NULL, NULL, NULL, ffestb_local_.decl.recursive, NULL); + break; + + case FFESTR_firstSUBROUTINE: + ffestc_R1223 (ffesta_tokens[1], ffestb_subrargs_.name_list.args, + ffestb_subrargs_.name_list.close_paren, + ffestb_local_.decl.recursive); + break; + + case FFESTR_firstENTRY: + ffestc_R1226 (ffesta_tokens[1], ffestb_subrargs_.name_list.args, + ffestb_subrargs_.name_list.close_paren); + break; + + default: + assert (FALSE); + } + } + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + ffelex_token_kill (ffestb_subrargs_.name_list.close_paren); + if (ffestb_subrargs_.name_list.args != NULL) + ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeNAME: + ffesta_confirmed (); + if ((ffestb_local_.dummy.first_kw != FFESTR_firstFUNCTION) + || (ffestr_other (t) != FFESTR_otherRESULT)) + break; + ffestb_local_.decl.type = FFESTP_typeNone; + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_funcname_6_; + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_local_.dummy.badname, t); + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + ffelex_token_kill (ffestb_subrargs_.name_list.close_paren); + if (ffestb_subrargs_.name_list.args != NULL) + ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R524 -- Parse the DIMENSION statement + + return ffestb_R524; // to lexer + + Make sure the statement has a valid form for the DIMENSION statement. If + it does, implement the statement. */ + +ffelexHandler +ffestb_R524 (ffelexToken t) +{ + ffeTokenLength i; + char *p; + ffelexToken nt; + ffelexHandler next; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R524_start (ffesta_first_kw == FFESTR_firstVIRTUAL); + ffestb_local_.dimension.started = TRUE; + return (ffelexHandler) ffestb_R5241_ (t); + } + + case FFELEX_typeNAMES: + p = ffelex_token_text (ffesta_tokens[0]) + (i = ffestb_args.R524.len); + switch (ffelex_token_type (t)) + { + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + break; + } + + /* Here, we have at least one char after "DIMENSION" and t is + OPEN_PAREN. */ + + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + ffestb_local_.dimension.started = FALSE; + next = (ffelexHandler) ffestb_R5241_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5241_ -- "DIMENSION" + + return ffestb_R5241_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_R5241_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R5242_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R524_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5242_ -- "DIMENSION" ... NAME + + return ffestb_R5242_; // to lexer + + Handle OPEN_PAREN. */ + +static ffelexHandler +ffestb_R5242_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + ffestb_subrargs_.dim_list.dims = ffestt_dimlist_create (); + ffestb_subrargs_.dim_list.handler = (ffelexHandler) ffestb_R5243_; + ffestb_subrargs_.dim_list.pool = ffesta_output_pool; + ffestb_subrargs_.dim_list.ctx = ffesta_is_entry_valid + ? FFEEXPR_contextDIMLIST : FFEEXPR_contextDIMLISTCOMMON; +#ifdef FFECOM_dimensionsMAX + ffestb_subrargs_.dim_list.ndims = 0; +#endif + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + ffestb_subrargs_.dim_list.ctx, + (ffeexprCallback) ffestb_subr_dimlist_); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R524_finish (); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5243_ -- "DIMENSION" ... NAME OPEN_PAREN dimlist CLOSE_PAREN + + return ffestb_R5243_; // to lexer + + Handle COMMA or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_R5243_ (ffelexToken t) +{ + if (!ffestb_subrargs_.dim_list.ok) + goto bad; /* :::::::::::::::::::: */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + if (!ffestb_local_.dimension.started) + { + ffestc_R524_start (ffesta_first_kw == FFESTR_firstVIRTUAL); + ffestb_local_.dimension.started = TRUE; + } + ffestc_R524_item (ffesta_tokens[1], + ffestb_subrargs_.dim_list.dims); + } + ffelex_token_kill (ffesta_tokens[1]); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + return (ffelexHandler) ffestb_R5244_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + if (!ffestb_local_.dimension.started) + { + ffestc_R524_start (ffesta_first_kw == FFESTR_firstVIRTUAL); + ffestb_local_.dimension.started = TRUE; + } + ffestc_R524_item (ffesta_tokens[1], + ffestb_subrargs_.dim_list.dims); + ffestc_R524_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, t); + if (ffestb_local_.dimension.started && !ffesta_is_inhibited ()) + ffestc_R524_finish (); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5244_ -- "DIMENSION" ... COMMA + + return ffestb_R5244_; // to lexer + + Make sure we don't have EOS or SEMICOLON. */ + +static ffelexHandler +ffestb_R5244_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + ffestc_R524_finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, ffestb_args.R524.badname, t); + return (ffelexHandler) ffesta_zero (t); + + default: + return (ffelexHandler) ffestb_R5241_ (t); + } +} + +/* ffestb_R547 -- Parse the COMMON statement + + return ffestb_R547; // to lexer + + Make sure the statement has a valid form for the COMMON statement. If it + does, implement the statement. */ + +ffelexHandler +ffestb_R547 (ffelexToken t) +{ + ffeTokenLength i; + char *p; + ffelexToken nt; + ffelexHandler next; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstCOMMON) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + case FFELEX_typeSLASH: + case FFELEX_typeCONCAT: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R547_start (); + ffestb_local_.common.started = TRUE; + return (ffelexHandler) ffestb_R5471_ (t); + } + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstCOMMON) + goto bad_0; /* :::::::::::::::::::: */ + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCOMMON); + switch (ffelex_token_type (t)) + { + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); + break; + + case FFELEX_typeSLASH: + case FFELEX_typeCONCAT: + ffesta_confirmed (); + if (*p != '\0') + break; + if (!ffesta_is_inhibited ()) + ffestc_R547_start (); + ffestb_local_.common.started = TRUE; + return (ffelexHandler) ffestb_R5471_ (t); + + case FFELEX_typeOPEN_PAREN: + break; + } + + /* Here, we have at least one char after "COMMON" and t is COMMA, + EOS/SEMICOLON, OPEN_PAREN, SLASH, or CONCAT. */ + + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN) + ffestb_local_.common.started = FALSE; + else + { + if (!ffesta_is_inhibited ()) + ffestc_R547_start (); + ffestb_local_.common.started = TRUE; + } + next = (ffelexHandler) ffestb_R5471_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "COMMON", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5471_ -- "COMMON" + + return ffestb_R5471_; // to lexer + + Handle NAME, SLASH, or CONCAT. */ + +static ffelexHandler +ffestb_R5471_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + return (ffelexHandler) ffestb_R5474_ (t); + + case FFELEX_typeSLASH: + return (ffelexHandler) ffestb_R5472_; + + case FFELEX_typeCONCAT: + if (!ffesta_is_inhibited ()) + ffestc_R547_item_cblock (NULL); + return (ffelexHandler) ffestb_R5474_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R547_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5472_ -- "COMMON" SLASH + + return ffestb_R5472_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_R5472_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R5473_; + + case FFELEX_typeSLASH: + if (!ffesta_is_inhibited ()) + ffestc_R547_item_cblock (NULL); + return (ffelexHandler) ffestb_R5474_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R547_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5473_ -- "COMMON" SLASH NAME + + return ffestb_R5473_; // to lexer + + Handle SLASH. */ + +static ffelexHandler +ffestb_R5473_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeSLASH: + if (!ffesta_is_inhibited ()) + ffestc_R547_item_cblock (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_R5474_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R547_finish (); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5474_ -- "COMMON" [SLASH NAME SLASH] or "COMMON" CONCAT + + return ffestb_R5474_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_R5474_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_R5475_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R547_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5475_ -- "COMMON" ... NAME + + return ffestb_R5475_; // to lexer + + Handle OPEN_PAREN. */ + +static ffelexHandler +ffestb_R5475_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + ffestb_subrargs_.dim_list.dims = ffestt_dimlist_create (); + ffestb_subrargs_.dim_list.handler = (ffelexHandler) ffestb_R5476_; + ffestb_subrargs_.dim_list.pool = ffesta_output_pool; + ffestb_subrargs_.dim_list.ctx = FFEEXPR_contextDIMLISTCOMMON; +#ifdef FFECOM_dimensionsMAX + ffestb_subrargs_.dim_list.ndims = 0; +#endif + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextDIMLISTCOMMON, (ffeexprCallback) ffestb_subr_dimlist_); + + case FFELEX_typeCOMMA: + if (!ffesta_is_inhibited ()) + ffestc_R547_item_object (ffesta_tokens[1], NULL); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_R5477_; + + case FFELEX_typeSLASH: + case FFELEX_typeCONCAT: + if (!ffesta_is_inhibited ()) + ffestc_R547_item_object (ffesta_tokens[1], NULL); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_R5471_ (t); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + { + ffestc_R547_item_object (ffesta_tokens[1], NULL); + ffestc_R547_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_R547_finish (); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5476_ -- "COMMON" ... NAME OPEN_PAREN dimlist CLOSE_PAREN + + return ffestb_R5476_; // to lexer + + Handle COMMA, SLASH, CONCAT, EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_R5476_ (ffelexToken t) +{ + if (!ffestb_subrargs_.dim_list.ok) + goto bad; /* :::::::::::::::::::: */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + if (!ffestb_local_.common.started) + { + ffestc_R547_start (); + ffestb_local_.common.started = TRUE; + } + ffestc_R547_item_object (ffesta_tokens[1], + ffestb_subrargs_.dim_list.dims); + } + ffelex_token_kill (ffesta_tokens[1]); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + return (ffelexHandler) ffestb_R5477_; + + case FFELEX_typeSLASH: + case FFELEX_typeCONCAT: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + if (!ffestb_local_.common.started) + { + ffestc_R547_start (); + ffestb_local_.common.started = TRUE; + } + ffestc_R547_item_object (ffesta_tokens[1], + ffestb_subrargs_.dim_list.dims); + } + ffelex_token_kill (ffesta_tokens[1]); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + return (ffelexHandler) ffestb_R5471_ (t); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + if (!ffestb_local_.common.started) + ffestc_R547_start (); + ffestc_R547_item_object (ffesta_tokens[1], + ffestb_subrargs_.dim_list.dims); + ffestc_R547_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t); + if (ffestb_local_.common.started && !ffesta_is_inhibited ()) + ffestc_R547_finish (); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R5477_ -- "COMMON" ... COMMA + + return ffestb_R5477_; // to lexer + + Make sure we don't have EOS or SEMICOLON. */ + +static ffelexHandler +ffestb_R5477_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + ffestc_R547_finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "COMMON", t); + return (ffelexHandler) ffesta_zero (t); + + default: + return (ffelexHandler) ffestb_R5471_ (t); + } +} + +/* ffestb_R624 -- Parse a NULLIFY statement + + return ffestb_R624; // to lexer + + Make sure the statement has a valid form for a NULLIFY + statement. If it does, implement the statement. + + 31-May-90 JCB 2.0 + Rewrite to produce a list of expressions rather than just names; this + eases semantic checking, putting it in expression handling where that + kind of thing gets done anyway, and makes it easier to support more + flexible extensions to Fortran 90 like NULLIFY(FOO%BAR). */ + +#if FFESTR_F90 +ffelexHandler +ffestb_R624 (ffelexToken t) +{ + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstNULLIFY) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstNULLIFY) + goto bad_0; /* :::::::::::::::::::: */ + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlNULLIFY) + goto bad_0; /* :::::::::::::::::::: */ + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + case FFELEX_typeNAME: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + ffestb_local_.R624.exprs = ffestt_exprlist_create (); + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextNULLIFY, + (ffeexprCallback) ffestb_R6241_); + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NULLIFY", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NULLIFY", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_R6241_ -- "NULLIFY" OPEN_PAREN expr + + return ffestb_R6241_; // to lexer + + Make sure the statement has a valid form for a NULLIFY statement. If it + does, implement the statement. + + 31-May-90 JCB 2.0 + Rewrite to produce a list of expressions rather than just names; this + eases semantic checking, putting it in expression handling where that + kind of thing gets done anyway, and makes it easier to support more + flexible extensions to Fortran 90 like NULLIFY(FOO%BAR). */ + +static ffelexHandler +ffestb_R6241_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestt_exprlist_append (ffestb_local_.R624.exprs, expr, + ffelex_token_use (t)); + return (ffelexHandler) ffestb_R6242_; + + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + ffestt_exprlist_append (ffestb_local_.R624.exprs, expr, + ffelex_token_use (t)); + return (ffelexHandler) ffeexpr_lhs (ffesta_output_pool, + FFEEXPR_contextNULLIFY, + (ffeexprCallback) ffestb_R6241_); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NULLIFY", t); + ffestt_exprlist_kill (ffestb_local_.R624.exprs); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R6242_ -- "NULLIFY" OPEN_PAREN expr-list CLOSE_PAREN + + return ffestb_R6242_; // to lexer + + Make sure the statement has a valid form for a NULLIFY statement. If it + does, implement the statement. */ + +static ffelexHandler +ffestb_R6242_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R624 (ffestb_local_.R624.exprs); + ffestt_exprlist_kill (ffestb_local_.R624.exprs); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "NULLIFY", t); + ffestt_exprlist_kill (ffestb_local_.R624.exprs); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_R1229 -- Parse a STMTFUNCTION statement + + return ffestb_R1229; // to lexer + + Make sure the statement has a valid form for a STMTFUNCTION + statement. If it does, implement the statement. */ + +ffelexHandler +ffestb_R1229 (ffelexToken t) +{ + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + case FFELEX_typeNAMES: + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + case FFELEX_typeNAME: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + ffestb_subrargs_.name_list.args = ffestt_tokenlist_create (); + ffestb_subrargs_.name_list.handler = (ffelexHandler) ffestb_R12291_; + ffestb_subrargs_.name_list.is_subr = FALSE; /* No "*" items in list! */ + ffestb_subrargs_.name_list.names = TRUE; /* In case "IF(FOO)CALL + FOO...". */ + return (ffelexHandler) ffestb_subr_name_list_; + +bad_0: /* :::::::::::::::::::: */ +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_2t (FFEBAD_UNREC_STMT, ffesta_tokens[0], t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R12291_ -- "STMTFUNCTION" OPEN_PAREN dummy-name-list CLOSE_PAREN + + return ffestb_R12291_; // to lexer + + Make sure the statement has a valid form for a STMTFUNCTION statement. If + it does, implement the statement. */ + +static ffelexHandler +ffestb_R12291_ (ffelexToken t) +{ + ffelex_set_names (FALSE); + + if (!ffestb_subrargs_.name_list.ok) + goto bad; /* :::::::::::::::::::: */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R1229_start (ffesta_tokens[0], + ffestb_subrargs_.name_list.args, + ffestb_subrargs_.name_list.close_paren); + ffelex_token_kill (ffestb_subrargs_.name_list.close_paren); + ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextSFUNCDEF, (ffeexprCallback) ffestb_R12292_); + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffesta_ffebad_2t (FFEBAD_UNREC_STMT, ffesta_tokens[0], t); + ffelex_token_kill (ffestb_subrargs_.name_list.close_paren); + ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_R12292_ -- "STMTFUNCTION" OPEN_PAREN dummy-name-list CLOSE_PAREN + EQUALS expr + + (ffestb_R12292_) // to expression handler + + Make sure the statement has a valid form for a STMTFUNCTION statement. If + it does, implement the statement. */ + +static ffelexHandler +ffestb_R12292_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + if (expr == NULL) + goto bad; /* :::::::::::::::::::: */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + ffestc_R1229_finish (expr, ft); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffestc_R1229_finish (NULL, NULL); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "statement-function-definition", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_chartype -- Parse the CHARACTER statement + + return ffestb_decl_chartype; // to lexer + + Make sure the statement has a valid form for the CHARACTER statement. If + it does, implement the statement. */ + +ffelexHandler +ffestb_decl_chartype (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + ffestb_local_.decl.type = FFESTP_typeCHARACTER; + ffestb_local_.decl.recursive = NULL; + ffestb_local_.decl.parameter = FALSE; /* No PARAMETER attribute seen. */ + ffestb_local_.decl.coloncolon = FALSE; /* No COLONCOLON seen. */ + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstCHRCTR) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + NULL, NULL, NULL, NULL); + return (ffelexHandler) ffestb_decl_attrs_; + + case FFELEX_typeCOLONCOLON: + ffestb_local_.decl.coloncolon = TRUE; + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + NULL, NULL, NULL, NULL); + return (ffelexHandler) ffestb_decl_ents_; + + case FFELEX_typeASTERISK: + ffesta_confirmed (); + ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_chartype1_; + ffestb_local_.decl.badname = "TYPEDECL"; + return (ffelexHandler) ffestb_decl_starlen_; + + case FFELEX_typeOPEN_PAREN: + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_; + ffestb_local_.decl.badname = "_TYPEDECL"; + return (ffelexHandler) ffestb_decl_typeparams_; + + case FFELEX_typeNAME: + ffesta_confirmed (); + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_entsp_ (t); + } + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstCHRCTR) + goto bad_0; /* :::::::::::::::::::: */ + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlCHRCTR); + switch (ffelex_token_type (t)) + { + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + break; + + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (*p != '\0') + break; + if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + NULL, NULL, NULL, NULL); + return (ffelexHandler) ffestb_decl_attrs_; + + case FFELEX_typeCOLONCOLON: + ffestb_local_.decl.coloncolon = TRUE; + ffesta_confirmed (); + if (*p != '\0') + goto bad_i; /* :::::::::::::::::::: */ + if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + NULL, NULL, NULL, NULL); + return (ffelexHandler) ffestb_decl_ents_; + + case FFELEX_typeASTERISK: + ffesta_confirmed (); + if (*p != '\0') + break; + ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_chartype1_; + ffestb_local_.decl.badname = "TYPEDECL"; + return (ffelexHandler) ffestb_decl_starlen_; + + case FFELEX_typeSLASH: + ffesta_confirmed (); + if (*p != '\0') + break; + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + if (*p != '\0') + break; + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_; + ffestb_local_.decl.badname = "TYPEDECL"; + return (ffelexHandler) ffestb_decl_typeparams_; + } + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + ffesta_tokens[1] = ffelex_token_names_from_names (ffesta_tokens[0], i, 0); + return (ffelexHandler) ffestb_decl_entsp_2_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_chartype1_ -- "CHARACTER" ASTERISK char-length + + return ffestb_decl_chartype1_; // to lexer + + Handle COMMA, COLONCOLON, or anything else. */ + +static ffelexHandler +ffestb_decl_chartype1_ (ffelexToken t) +{ + ffelex_set_names (FALSE); + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOLONCOLON: + ffestb_local_.decl.coloncolon = TRUE; + /* Fall through. */ + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + NULL, NULL, ffestb_local_.decl.len, ffestb_local_.decl.lent); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + return (ffelexHandler) ffestb_decl_ents_; + + default: + return (ffelexHandler) ffestb_decl_entsp_ (t); + } +} + +/* ffestb_decl_dbltype -- Parse the DOUBLEPRECISION/DOUBLECOMPLEX statement + + return ffestb_decl_dbltype; // to lexer + + Make sure the statement has a valid form for the DOUBLEPRECISION/ + DOUBLECOMPLEX statement. If it does, implement the statement. */ + +ffelexHandler +ffestb_decl_dbltype (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + ffestb_local_.decl.type = ffestb_args.decl.type; + ffestb_local_.decl.recursive = NULL; + ffestb_local_.decl.parameter = FALSE; /* No PARAMETER attribute seen. */ + ffestb_local_.decl.coloncolon = FALSE; /* No COLONCOLON seen. */ + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + NULL, NULL, NULL, NULL); + return (ffelexHandler) ffestb_decl_attrs_; + + case FFELEX_typeCOLONCOLON: + ffestb_local_.decl.coloncolon = TRUE; + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + NULL, NULL, NULL, NULL); + return (ffelexHandler) ffestb_decl_ents_; + + case FFELEX_typeNAME: + ffesta_confirmed (); + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_entsp_ (t); + } + + case FFELEX_typeNAMES: + p = ffelex_token_text (ffesta_tokens[0]) + (i = ffestb_args.decl.len); + switch (ffelex_token_type (t)) + { + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + break; + + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (*p != '\0') + break; + if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + NULL, NULL, NULL, NULL); + return (ffelexHandler) ffestb_decl_attrs_; + + case FFELEX_typeCOLONCOLON: + ffestb_local_.decl.coloncolon = TRUE; + ffesta_confirmed (); + if (*p != '\0') + goto bad_i; /* :::::::::::::::::::: */ + if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + NULL, NULL, NULL, NULL); + return (ffelexHandler) ffestb_decl_ents_; + + case FFELEX_typeSLASH: + ffesta_confirmed (); + if (*p != '\0') + break; + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeOPEN_PAREN: + if (*p != '\0') + break; + goto bad_1; /* :::::::::::::::::::: */ + } + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + ffesta_tokens[1] = ffelex_token_names_from_names (ffesta_tokens[0], i, 0); + return (ffelexHandler) ffestb_decl_entsp_2_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_double -- Parse the DOUBLE PRECISION/DOUBLE COMPLEX statement + + return ffestb_decl_double; // to lexer + + Make sure the statement has a valid form for the DOUBLE PRECISION/ + DOUBLE COMPLEX statement. If it does, implement the statement. */ + +ffelexHandler +ffestb_decl_double (ffelexToken t) +{ + ffestb_local_.decl.recursive = NULL; + ffestb_local_.decl.parameter = FALSE; /* No PARAMETER attribute seen. */ + ffestb_local_.decl.coloncolon = FALSE; /* No COLONCOLON seen. */ + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstDBL) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + ffesta_confirmed (); + switch (ffestr_second (t)) + { + case FFESTR_secondCOMPLEX: + ffestb_local_.decl.type = FFESTP_typeDBLCMPLX; + break; + + case FFESTR_secondPRECISION: + ffestb_local_.decl.type = FFESTP_typeDBLPRCSN; + break; + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_attrsp_; + } + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_decl_gentype -- Parse the INTEGER/REAL/COMPLEX/LOGICAL statement + + return ffestb_decl_gentype; // to lexer + + Make sure the statement has a valid form for the INTEGER/REAL/COMPLEX/ + LOGICAL statement. If it does, implement the statement. */ + +ffelexHandler +ffestb_decl_gentype (ffelexToken t) +{ + ffeTokenLength i; + char *p; + + ffestb_local_.decl.type = ffestb_args.decl.type; + ffestb_local_.decl.recursive = NULL; + ffestb_local_.decl.parameter = FALSE; /* No PARAMETER attribute seen. */ + ffestb_local_.decl.coloncolon = FALSE; /* No COLONCOLON seen. */ + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + NULL, NULL, NULL, NULL); + return (ffelexHandler) ffestb_decl_attrs_; + + case FFELEX_typeCOLONCOLON: + ffestb_local_.decl.coloncolon = TRUE; + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + NULL, NULL, NULL, NULL); + return (ffelexHandler) ffestb_decl_ents_; + + case FFELEX_typeASTERISK: + ffesta_confirmed (); + ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_; + ffestb_local_.decl.badname = "TYPEDECL"; + return (ffelexHandler) ffestb_decl_starkind_; + + case FFELEX_typeOPEN_PAREN: + ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_; + ffestb_local_.decl.badname = "TYPEDECL"; + return (ffelexHandler) ffestb_decl_kindparam_; + + case FFELEX_typeNAME: + ffesta_confirmed (); + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_entsp_ (t); + } + + case FFELEX_typeNAMES: + p = ffelex_token_text (ffesta_tokens[0]) + (i = ffestb_args.decl.len); + switch (ffelex_token_type (t)) + { + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + break; + + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (*p != '\0') + break; + if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + NULL, NULL, NULL, NULL); + return (ffelexHandler) ffestb_decl_attrs_; + + case FFELEX_typeCOLONCOLON: + ffestb_local_.decl.coloncolon = TRUE; + ffesta_confirmed (); + if (*p != '\0') + goto bad_i; /* :::::::::::::::::::: */ + if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + NULL, NULL, NULL, NULL); + return (ffelexHandler) ffestb_decl_ents_; + + case FFELEX_typeSLASH: + ffesta_confirmed (); + if (*p != '\0') + break; + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeASTERISK: + ffesta_confirmed (); + if (*p != '\0') + break; + ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_; + ffestb_local_.decl.badname = "TYPEDECL"; + return (ffelexHandler) ffestb_decl_starkind_; + + case FFELEX_typeOPEN_PAREN: + if (*p != '\0') + break; + ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_; + ffestb_local_.decl.badname = "TYPEDECL"; + return (ffelexHandler) ffestb_decl_kindparam_; + } + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + ffesta_tokens[1] = ffelex_token_names_from_names (ffesta_tokens[0], i, 0); + return (ffelexHandler) ffestb_decl_entsp_2_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_recursive -- Parse the RECURSIVE FUNCTION statement + + return ffestb_decl_recursive; // to lexer + + Make sure the statement has a valid form for the RECURSIVE FUNCTION + statement. If it does, implement the statement. */ + +#if FFESTR_F90 +ffelexHandler +ffestb_decl_recursive (ffelexToken t) +{ + ffeTokenLength i; + char *p; + ffelexToken nt; + ffelexToken ot; + ffelexHandler next; + bool needfunc; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstRECURSIVE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + break; + } + ffesta_confirmed (); + ffestb_local_.decl.recursive = ffelex_token_use (ffesta_tokens[0]); + switch (ffesta_second_kw) + { + case FFESTR_secondINTEGER: + ffestb_local_.decl.type = FFESTP_typeINTEGER; + return (ffelexHandler) ffestb_decl_recursive1_; + + case FFESTR_secondBYTE: + ffestb_local_.decl.type = FFESTP_typeBYTE; + return (ffelexHandler) ffestb_decl_recursive1_; + + case FFESTR_secondWORD: + ffestb_local_.decl.type = FFESTP_typeWORD; + return (ffelexHandler) ffestb_decl_recursive1_; + + case FFESTR_secondREAL: + ffestb_local_.decl.type = FFESTP_typeREAL; + return (ffelexHandler) ffestb_decl_recursive1_; + + case FFESTR_secondCOMPLEX: + ffestb_local_.decl.type = FFESTP_typeCOMPLEX; + return (ffelexHandler) ffestb_decl_recursive1_; + + case FFESTR_secondLOGICAL: + ffestb_local_.decl.type = FFESTP_typeLOGICAL; + return (ffelexHandler) ffestb_decl_recursive1_; + + case FFESTR_secondCHARACTER: + ffestb_local_.decl.type = FFESTP_typeCHARACTER; + return (ffelexHandler) ffestb_decl_recursive1_; + + case FFESTR_secondDOUBLE: + return (ffelexHandler) ffestb_decl_recursive2_; + + case FFESTR_secondDOUBLEPRECISION: + ffestb_local_.decl.type = FFESTP_typeDBLPRCSN; + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_func_; + + case FFESTR_secondDOUBLECOMPLEX: + ffestb_local_.decl.type = FFESTP_typeDBLCMPLX; + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_func_; + + case FFESTR_secondTYPE: + ffestb_local_.decl.type = FFESTP_typeTYPE; + return (ffelexHandler) ffestb_decl_recursive3_; + + case FFESTR_secondFUNCTION: + ffestb_local_.dummy.first_kw = FFESTR_firstFUNCTION; + ffestb_local_.dummy.badname = "FUNCTION"; + ffestb_local_.dummy.is_subr = FALSE; + return (ffelexHandler) ffestb_decl_recursive4_; + + case FFESTR_secondSUBROUTINE: + ffestb_local_.dummy.first_kw = FFESTR_firstSUBROUTINE; + ffestb_local_.dummy.badname = "SUBROUTINE"; + ffestb_local_.dummy.is_subr = TRUE; + return (ffelexHandler) ffestb_decl_recursive4_; + + default: + ffelex_token_kill (ffestb_local_.decl.recursive); + goto bad_1; /* :::::::::::::::::::: */ + } + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstRECURSIVE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + case FFELEX_typeASTERISK: + case FFELEX_typeSEMICOLON: + case FFELEX_typeEOS: + ffesta_confirmed (); + break; + + default: + break; + } + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlRECURSIVE); + if (!ffesrc_is_name_init (*p)) + goto bad_0; /* :::::::::::::::::::: */ + ffestb_local_.decl.recursive + = ffelex_token_name_from_names (ffesta_tokens[0], 0, + FFESTR_firstlRECURSIVE); + nt = ffelex_token_names_from_names (ffesta_tokens[0], + FFESTR_firstlRECURSIVE, 0); + switch (ffestr_first (nt)) + { + case FFESTR_firstINTGR: + p = ffelex_token_text (nt) + (i = FFESTR_firstlINTGR); + ffestb_local_.decl.type = FFESTP_typeINTEGER; + needfunc = FALSE; + goto typefunc; /* :::::::::::::::::::: */ + + case FFESTR_firstBYTE: + p = ffelex_token_text (nt) + (i = FFESTR_firstlBYTE); + ffestb_local_.decl.type = FFESTP_typeBYTE; + needfunc = FALSE; + goto typefunc; /* :::::::::::::::::::: */ + + case FFESTR_firstWORD: + p = ffelex_token_text (nt) + (i = FFESTR_firstlWORD); + ffestb_local_.decl.type = FFESTP_typeWORD; + needfunc = FALSE; + goto typefunc; /* :::::::::::::::::::: */ + + case FFESTR_firstREAL: + p = ffelex_token_text (nt) + (i = FFESTR_firstlREAL); + ffestb_local_.decl.type = FFESTP_typeREAL; + needfunc = FALSE; + goto typefunc; /* :::::::::::::::::::: */ + + case FFESTR_firstCMPLX: + p = ffelex_token_text (nt) + (i = FFESTR_firstlCMPLX); + ffestb_local_.decl.type = FFESTP_typeCOMPLEX; + needfunc = FALSE; + goto typefunc; /* :::::::::::::::::::: */ + + case FFESTR_firstLGCL: + p = ffelex_token_text (nt) + (i = FFESTR_firstlLGCL); + ffestb_local_.decl.type = FFESTP_typeLOGICAL; + needfunc = FALSE; + goto typefunc; /* :::::::::::::::::::: */ + + case FFESTR_firstCHRCTR: + p = ffelex_token_text (nt) + (i = FFESTR_firstlCHRCTR); + ffestb_local_.decl.type = FFESTP_typeCHARACTER; + needfunc = FALSE; + goto typefunc; /* :::::::::::::::::::: */ + + case FFESTR_firstDBLPRCSN: + p = ffelex_token_text (nt) + (i = FFESTR_firstlDBLPRCSN); + ffestb_local_.decl.type = FFESTP_typeDBLPRCSN; + needfunc = TRUE; + goto typefunc; /* :::::::::::::::::::: */ + + case FFESTR_firstDBLCMPLX: + p = ffelex_token_text (nt) + (i = FFESTR_firstlDBLCMPLX); + ffestb_local_.decl.type = FFESTP_typeDBLCMPLX; + needfunc = TRUE; + goto typefunc; /* :::::::::::::::::::: */ + + case FFESTR_firstTYPE: + p = ffelex_token_text (nt) + (i = FFESTR_firstlTYPE); + ffestb_local_.decl.type = FFESTP_typeTYPE; + next = (ffelexHandler) ffestb_decl_recursive3_; + break; + + case FFESTR_firstFUNCTION: + p = ffelex_token_text (nt) + (i = FFESTR_firstlFUNCTION); + ffestb_local_.dummy.first_kw = FFESTR_firstFUNCTION; + ffestb_local_.dummy.badname = "FUNCTION"; + ffestb_local_.dummy.is_subr = FALSE; + next = (ffelexHandler) ffestb_decl_recursive4_; + break; + + case FFESTR_firstSUBROUTINE: + p = ffelex_token_text (nt) + (i = FFESTR_firstlSUBROUTINE); + ffestb_local_.dummy.first_kw = FFESTR_firstSUBROUTINE; + ffestb_local_.dummy.badname = "SUBROUTINE"; + ffestb_local_.dummy.is_subr = TRUE; + next = (ffelexHandler) ffestb_decl_recursive4_; + break; + + default: + ffelex_token_kill (ffestb_local_.decl.recursive); + ffelex_token_kill (nt); + goto bad_1; /* :::::::::::::::::::: */ + } + if (*p == '\0') + { + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + } + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ot = ffelex_token_name_from_names (nt, i, 0); + ffelex_token_kill (nt); + next = (ffelexHandler) (*next) (ot); + ffelex_token_kill (ot); + return (ffelexHandler) (*next) (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +typefunc: /* :::::::::::::::::::: */ + if (*p == '\0') + { + ffelex_token_kill (nt); + if (needfunc) /* DOUBLE PRECISION or DOUBLE COMPLEX? */ + { + ffelex_token_kill (ffestb_local_.decl.recursive); + goto bad_1; /* :::::::::::::::::::: */ + } + return (ffelexHandler) ffestb_decl_recursive1_ (t); + } + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ot = ffelex_token_names_from_names (nt, i, 0); + ffelex_token_kill (nt); + if (ffestr_first (ot) != FFESTR_firstFUNCTION) + goto bad_o; /* :::::::::::::::::::: */ + p = ffelex_token_text (ot) + (i = FFESTR_firstlFUNCTION); + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffesta_tokens[1] = ffelex_token_name_from_names (ot, i, 0); + ffelex_token_kill (ot); + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_funcname_1_ (t); + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffelex_token_kill (ffestb_local_.decl.recursive); + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "type-declaration", nt, i, t); + ffelex_token_kill (nt); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_o: /* :::::::::::::::::::: */ + ffelex_token_kill (ffestb_local_.decl.recursive); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", ot); + ffelex_token_kill (ot); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_recursive1_ -- "RECURSIVE" generic-type + + return ffestb_decl_recursive1_; // to lexer + + Handle ASTERISK, OPEN_PAREN, or NAME. */ + +static ffelexHandler +ffestb_decl_recursive1_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeASTERISK: + ffesta_confirmed (); + ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_func_; + ffestb_local_.decl.badname = "TYPEFUNC"; + if (ffestb_local_.decl.type == FFESTP_typeCHARACTER) + return (ffelexHandler) ffestb_decl_starlen_; + return (ffelexHandler) ffestb_decl_starkind_; + + case FFELEX_typeOPEN_PAREN: + ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_func_; + ffestb_local_.decl.badname = "TYPEFUNC"; + if (ffestb_local_.decl.type == FFESTP_typeCHARACTER) + { + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_typeparams_; + } + return (ffelexHandler) ffestb_decl_kindparam_; + + case FFELEX_typeNAME: + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_func_ (t); + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_recursive2_ -- "RECURSIVE" "DOUBLE" + + return ffestb_decl_recursive2_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_decl_recursive2_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + switch (ffestr_second (t)) + { + case FFESTR_secondPRECISION: + ffestb_local_.decl.type = FFESTP_typeDBLPRCSN; + break; + + case FFESTR_secondCOMPLEX: + ffestb_local_.decl.type = FFESTP_typeDBLCMPLX; + break; + + default: + goto bad; /* :::::::::::::::::::: */ + } + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_func_; + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_recursive3_ -- "RECURSIVE" "TYPE" + + return ffestb_decl_recursive3_; // to lexer + + Handle OPEN_PAREN. */ + +static ffelexHandler +ffestb_decl_recursive3_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_func_; + ffestb_local_.decl.badname = "TYPEFUNC"; + return (ffelexHandler) ffestb_decl_typetype1_; + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_recursive4_ -- "RECURSIVE" "FUNCTION/SUBROUTINE" + + return ffestb_decl_recursive4_; // to lexer + + Handle OPEN_PAREN. */ + +static ffelexHandler +ffestb_decl_recursive4_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_dummy1_; + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_decl_typetype -- Parse the R426/R501/R1219 TYPE statement + + return ffestb_decl_typetype; // to lexer + + Make sure the statement has a valid form for the TYPE statement. If it + does, implement the statement. */ + +#if FFESTR_F90 +ffelexHandler +ffestb_decl_typetype (ffelexToken t) +{ + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstTYPE) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstTYPE) + goto bad_0; /* :::::::::::::::::::: */ + if (ffelex_token_length (ffesta_tokens[0]) != FFESTR_firstlTYPE) + goto bad_0; /* :::::::::::::::::::: */ + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + break; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOLONCOLON:/* Not COMMA: R424 "TYPE,PUBLIC::A". */ + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + ffestb_local_.decl.recursive = NULL; + ffestb_local_.decl.parameter = FALSE; /* No PARAMETER attribute seen. */ + ffestb_local_.decl.coloncolon = FALSE; /* No COLONCOLON seen. */ + + ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_attrsp_; + ffestb_local_.decl.badname = "type-declaration"; + return (ffelexHandler) ffestb_decl_typetype1_; + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +#endif +/* ffestb_decl_attrs_ -- "type" [type parameters] COMMA + + return ffestb_decl_attrs_; // to lexer + + Handle NAME of an attribute. */ + +static ffelexHandler +ffestb_decl_attrs_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + switch (ffestr_first (t)) + { +#if FFESTR_F90 + case FFESTR_firstALLOCATABLE: + if (!ffesta_is_inhibited ()) + ffestc_decl_attrib (FFESTP_attribALLOCATABLE, t, + FFESTR_otherNone, NULL); + return (ffelexHandler) ffestb_decl_attrs_7_; +#endif + + case FFESTR_firstDIMENSION: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_decl_attrs_1_; + + case FFESTR_firstEXTERNAL: + if (!ffesta_is_inhibited ()) + ffestc_decl_attrib (FFESTP_attribEXTERNAL, t, + FFESTR_otherNone, NULL); + return (ffelexHandler) ffestb_decl_attrs_7_; + +#if FFESTR_F90 + case FFESTR_firstINTENT: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_decl_attrs_3_; +#endif + + case FFESTR_firstINTRINSIC: + if (!ffesta_is_inhibited ()) + ffestc_decl_attrib (FFESTP_attribINTRINSIC, t, + FFESTR_otherNone, NULL); + return (ffelexHandler) ffestb_decl_attrs_7_; + +#if FFESTR_F90 + case FFESTR_firstOPTIONAL: + if (!ffesta_is_inhibited ()) + ffestc_decl_attrib (FFESTP_attribOPTIONAL, t, + FFESTR_otherNone, NULL); + return (ffelexHandler) ffestb_decl_attrs_7_; +#endif + + case FFESTR_firstPARAMETER: + ffestb_local_.decl.parameter = TRUE; + if (!ffesta_is_inhibited ()) + ffestc_decl_attrib (FFESTP_attribPARAMETER, t, + FFESTR_otherNone, NULL); + return (ffelexHandler) ffestb_decl_attrs_7_; + +#if FFESTR_F90 + case FFESTR_firstPOINTER: + if (!ffesta_is_inhibited ()) + ffestc_decl_attrib (FFESTP_attribPOINTER, t, + FFESTR_otherNone, NULL); + return (ffelexHandler) ffestb_decl_attrs_7_; +#endif + +#if FFESTR_F90 + case FFESTR_firstPRIVATE: + if (!ffesta_is_inhibited ()) + ffestc_decl_attrib (FFESTP_attribPRIVATE, t, + FFESTR_otherNone, NULL); + return (ffelexHandler) ffestb_decl_attrs_7_; + + case FFESTR_firstPUBLIC: + if (!ffesta_is_inhibited ()) + ffestc_decl_attrib (FFESTP_attribPUBLIC, t, + FFESTR_otherNone, NULL); + return (ffelexHandler) ffestb_decl_attrs_7_; +#endif + + case FFESTR_firstSAVE: + if (!ffesta_is_inhibited ()) + ffestc_decl_attrib (FFESTP_attribSAVE, t, + FFESTR_otherNone, NULL); + return (ffelexHandler) ffestb_decl_attrs_7_; + +#if FFESTR_F90 + case FFESTR_firstTARGET: + if (!ffesta_is_inhibited ()) + ffestc_decl_attrib (FFESTP_attribTARGET, t, + FFESTR_otherNone, NULL); + return (ffelexHandler) ffestb_decl_attrs_7_; +#endif + + default: + ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_ATTR, t); + return (ffelexHandler) ffestb_decl_attrs_7_; + } + break; + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_decl_finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_attrs_1_ -- "type" [type parameters] ",DIMENSION" + + return ffestb_decl_attrs_1_; // to lexer + + Handle OPEN_PAREN. */ + +static ffelexHandler +ffestb_decl_attrs_1_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + ffestb_subrargs_.dim_list.dims = ffestt_dimlist_create (); + ffestb_subrargs_.dim_list.handler = (ffelexHandler) ffestb_decl_attrs_2_; + ffestb_subrargs_.dim_list.pool = ffesta_scratch_pool; + ffestb_subrargs_.dim_list.ctx = ffesta_is_entry_valid + ? FFEEXPR_contextDIMLIST : FFEEXPR_contextDIMLISTCOMMON; +#ifdef FFECOM_dimensionsMAX + ffestb_subrargs_.dim_list.ndims = 0; +#endif + return (ffelexHandler) ffeexpr_rhs (ffesta_scratch_pool, + ffestb_subrargs_.dim_list.ctx, + (ffeexprCallback) ffestb_subr_dimlist_); + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_ATTR, ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_decl_attrs_7_ (t); + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_decl_finish (); + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_ATTR, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_attrs_2_ -- "type" [type parameters] ",DIMENSION" OPEN_PAREN + dimlist CLOSE_PAREN + + return ffestb_decl_attrs_2_; // to lexer + + Handle COMMA or COLONCOLON. */ + +static ffelexHandler +ffestb_decl_attrs_2_ (ffelexToken t) +{ + if (!ffestb_subrargs_.dim_list.ok) + goto bad; /* :::::::::::::::::::: */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + if (!ffesta_is_inhibited ()) + ffestc_decl_attrib (FFESTP_attribDIMENSION, ffesta_tokens[1], + FFESTR_otherNone, ffestb_subrargs_.dim_list.dims); + ffelex_token_kill (ffesta_tokens[1]); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + return (ffelexHandler) ffestb_decl_attrs_7_ (t); + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + if (!ffesta_is_inhibited ()) + ffestc_decl_finish (); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_attrs_3_ -- "type" [type parameters] ",INTENT" + + return ffestb_decl_attrs_3_; // to lexer + + Handle OPEN_PAREN. */ + +#if FFESTR_F90 +static ffelexHandler +ffestb_decl_attrs_3_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + return (ffelexHandler) ffestb_decl_attrs_4_; + + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_ATTR, ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_decl_attrs_7_ (t); + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_decl_finish (); + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_ATTR, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_attrs_4_ -- "type" [type parameters] ",INTENT" OPEN_PAREN + + return ffestb_decl_attrs_4_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_decl_attrs_4_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffestb_local_.decl.kw = ffestr_other (t); + switch (ffestb_local_.decl.kw) + { + case FFESTR_otherIN: + return (ffelexHandler) ffestb_decl_attrs_5_; + + case FFESTR_otherINOUT: + return (ffelexHandler) ffestb_decl_attrs_6_; + + case FFESTR_otherOUT: + return (ffelexHandler) ffestb_decl_attrs_6_; + + default: + ffestb_local_.decl.kw = FFESTR_otherNone; + ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_ATTR, t); + return (ffelexHandler) ffestb_decl_attrs_5_; + } + break; + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_decl_finish (); + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_attrs_5_ -- "type" [type parameters] ",INTENT" OPEN_PAREN "IN" + + return ffestb_decl_attrs_5_; // to lexer + + Handle NAME or CLOSE_PAREN. */ + +static ffelexHandler +ffestb_decl_attrs_5_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + switch (ffestr_other (t)) + { + case FFESTR_otherOUT: + if (ffestb_local_.decl.kw != FFESTR_otherNone) + ffestb_local_.decl.kw = FFESTR_otherINOUT; + return (ffelexHandler) ffestb_decl_attrs_6_; + + default: + if (ffestb_local_.decl.kw != FFESTR_otherNone) + { + ffestb_local_.decl.kw = FFESTR_otherNone; + ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_ATTR, t); + } + return (ffelexHandler) ffestb_decl_attrs_5_; + } + break; + + case FFELEX_typeCLOSE_PAREN: + return (ffelexHandler) ffestb_decl_attrs_6_ (t); + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_decl_finish (); + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_attrs_6_ -- "type" [type parameters] ",INTENT" OPEN_PAREN "IN" + ["OUT"] + + return ffestb_decl_attrs_6_; // to lexer + + Handle CLOSE_PAREN. */ + +static ffelexHandler +ffestb_decl_attrs_6_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + if ((ffestb_local_.decl.kw != FFESTR_otherNone) + && !ffesta_is_inhibited ()) + ffestc_decl_attrib (FFESTP_attribINTENT, ffesta_tokens[1], + ffestb_local_.decl.kw, NULL); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_decl_attrs_7_; + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_decl_finish (); + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_decl_attrs_7_ -- "type" [type parameters] attribute + + return ffestb_decl_attrs_7_; // to lexer + + Handle COMMA (another attribute) or COLONCOLON (entities). */ + +static ffelexHandler +ffestb_decl_attrs_7_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_decl_attrs_; + + case FFELEX_typeCOLONCOLON: + ffestb_local_.decl.coloncolon = TRUE; + return (ffelexHandler) ffestb_decl_ents_; + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_decl_finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_attrsp_ -- "type" [type parameters] + + return ffestb_decl_attrsp_; // to lexer + + Handle COMMA (meaning we have attributes), COLONCOLON (meaning we have + no attributes but entities), or go to entsp to see about functions or + entities. */ + +static ffelexHandler +ffestb_decl_attrsp_ (ffelexToken t) +{ + ffelex_set_names (FALSE); + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + ffestb_local_.decl.kind, ffestb_local_.decl.kindt, + ffestb_local_.decl.len, ffestb_local_.decl.lent); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + return (ffelexHandler) ffestb_decl_attrs_; + + case FFELEX_typeCOLONCOLON: + ffestb_local_.decl.coloncolon = TRUE; + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + ffestb_local_.decl.kind, ffestb_local_.decl.kindt, + ffestb_local_.decl.len, ffestb_local_.decl.lent); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + return (ffelexHandler) ffestb_decl_ents_; + + default: + return (ffelexHandler) ffestb_decl_entsp_ (t); + } +} + +/* ffestb_decl_ents_ -- "type" [type parameters] [attributes "::"] + + return ffestb_decl_ents_; // to lexer + + Handle NAME of an entity. */ + +static ffelexHandler +ffestb_decl_ents_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_decl_ents_1_; + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_decl_finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_ents_1_ -- "type" [type parameters] [attributes "::"] NAME + + return ffestb_decl_ents_1_; // to lexer + + Handle ASTERISK, OPEN_PAREN, EQUALS, SLASH, COMMA, or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_decl_ents_1_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (!ffesta_is_inhibited ()) + ffestc_decl_item (ffesta_tokens[1], NULL, NULL, NULL, NULL, NULL, NULL, + NULL, FALSE); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_decl_ents_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + { + ffestc_decl_item (ffesta_tokens[1], NULL, NULL, NULL, NULL, NULL, NULL, + NULL, FALSE); + ffestc_decl_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeASTERISK: + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_ents_2_; + + case FFELEX_typeOPEN_PAREN: + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_ents_3_ (t); + + case FFELEX_typeEQUALS: + case FFELEX_typeSLASH: + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_subrargs_.dim_list.dims = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_ents_7_ (t); + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_decl_finish (); + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_ents_2_ -- "type" [type parameters] [attributes "::"] NAME + ASTERISK + + return ffestb_decl_ents_2_; // to lexer + + Handle NUMBER or OPEN_PAREN. */ + +static ffelexHandler +ffestb_decl_ents_2_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + if (ffestb_local_.decl.type != FFESTP_typeCHARACTER) + { + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = ffelex_token_use (t); + return (ffelexHandler) ffestb_decl_ents_3_; + } + /* Fall through. *//* (CHARACTER's *n is always a len spec. */ + case FFELEX_typeOPEN_PAREN:/* "*(" is after the (omitted) + "(array-spec)". */ + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_subrargs_.dim_list.dims = NULL; + return (ffelexHandler) ffestb_decl_ents_5_ (t); + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_decl_finish (); + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_ents_3_ -- "type" [type parameters] [attributes "::"] NAME + [ASTERISK NUMBER] + + return ffestb_decl_ents_3_; // to lexer + + Handle ASTERISK, OPEN_PAREN, EQUALS, SLASH, COMMA, or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_decl_ents_3_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (!ffesta_is_inhibited ()) + ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind, + ffestb_local_.decl.kindt, NULL, NULL, NULL, NULL, NULL, FALSE); + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + return (ffelexHandler) ffestb_decl_ents_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + { + ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind, + ffestb_local_.decl.kindt, NULL, NULL, NULL, NULL, NULL, FALSE); + ffestc_decl_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeASTERISK: + ffestb_subrargs_.dim_list.dims = NULL; + return (ffelexHandler) ffestb_decl_ents_5_; + + case FFELEX_typeOPEN_PAREN: + ffestb_subrargs_.dim_list.dims = ffestt_dimlist_create (); + ffestb_subrargs_.dim_list.handler = (ffelexHandler) ffestb_decl_ents_4_; + ffestb_subrargs_.dim_list.pool = ffesta_output_pool; + ffestb_subrargs_.dim_list.ctx = ffesta_is_entry_valid + ? FFEEXPR_contextDIMLIST : FFEEXPR_contextDIMLISTCOMMON; +#ifdef FFECOM_dimensionsMAX + ffestb_subrargs_.dim_list.ndims = 0; +#endif + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + ffestb_subrargs_.dim_list.ctx, + (ffeexprCallback) ffestb_subr_dimlist_); + + case FFELEX_typeEQUALS: + case FFELEX_typeSLASH: + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_subrargs_.dim_list.dims = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_ents_7_ (t); + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_decl_finish (); + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_ents_4_ -- "type" [type parameters] [attributes "::"] NAME + [ASTERISK NUMBER] [OPEN_PAREN dimlist CLOSE_PAREN] + + return ffestb_decl_ents_4_; // to lexer + + Handle ASTERISK, EQUALS, SLASH, COMMA, or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_decl_ents_4_ (ffelexToken t) +{ + ffelexToken nt; + + if (!ffestb_subrargs_.dim_list.ok) + goto bad; /* :::::::::::::::::::: */ + + if (ffelex_token_type (ffesta_tokens[1]) == FFELEX_typeNAMES) + { + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeASTERISK: + case FFELEX_typeSLASH: /* But NOT FFELEX_typeEQUALS. */ + case FFELEX_typeCOLONCOLON: /* Actually an error. */ + break; /* Confirm and handle. */ + + default: /* Perhaps EQUALS, as in + INTEGERFUNCTIONX(A)=B. */ + goto bad; /* :::::::::::::::::::: */ + } + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + nt = ffelex_token_name_from_names (ffesta_tokens[1], 0, 0); + ffelex_token_kill (ffesta_tokens[1]); + ffesta_tokens[1] = nt; + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + NULL, NULL, NULL, NULL); + } + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (!ffesta_is_inhibited ()) + ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind, + ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims, + ffestb_local_.decl.len, ffestb_local_.decl.lent, NULL, NULL, + FALSE); + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + return (ffelexHandler) ffestb_decl_ents_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + { + ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind, + ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims, + ffestb_local_.decl.len, ffestb_local_.decl.lent, NULL, NULL, + FALSE); + ffestc_decl_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeASTERISK: + if (ffestb_local_.decl.lent != NULL) + break; /* Can't specify "*length" twice. */ + return (ffelexHandler) ffestb_decl_ents_5_; + + case FFELEX_typeEQUALS: + case FFELEX_typeSLASH: + return (ffelexHandler) ffestb_decl_ents_7_ (t); + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + if ((ffelex_token_type (ffesta_tokens[1]) != FFELEX_typeNAMES) + && !ffesta_is_inhibited ()) + ffestc_decl_finish (); + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_ents_5_ -- "type" [type parameters] [attributes "::"] NAME + [ASTERISK NUMBER] [OPEN_PAREN dimlist CLOSE_PAREN] + ASTERISK + + return ffestb_decl_ents_5_; // to lexer + + Handle NUMBER or OPEN_PAREN. */ + +static ffelexHandler +ffestb_decl_ents_5_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = ffelex_token_use (t); + return (ffelexHandler) ffestb_decl_ents_7_; + + case FFELEX_typeOPEN_PAREN: + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextCHARACTERSIZE, (ffeexprCallback) ffestb_decl_ents_6_); + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_decl_finish (); + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_subrargs_.dim_list.dims != NULL) + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_ents_6_ -- "type" [type parameters] [attributes "::"] NAME + [ASTERISK NUMBER] [OPEN_PAREN dimlist CLOSE_PAREN] + ASTERISK OPEN_PAREN expr + + (ffestb_decl_ents_6_) // to expression handler + + Handle CLOSE_PAREN. */ + +static ffelexHandler +ffestb_decl_ents_6_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + ffestb_local_.decl.len = expr; + ffestb_local_.decl.lent = ffelex_token_use (ft); + return (ffelexHandler) ffestb_decl_ents_7_; + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_decl_finish (); + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_subrargs_.dim_list.dims != NULL) + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_ents_7_ -- "type" [type parameters] [attributes "::"] NAME + [ASTERISK NUMBER] [OPEN_PAREN dimlist CLOSE_PAREN] + [ASTERISK charlength] + + return ffestb_decl_ents_7_; // to lexer + + Handle EQUALS, SLASH, COMMA, or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_decl_ents_7_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (!ffesta_is_inhibited ()) + ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind, + ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims, + ffestb_local_.decl.len, ffestb_local_.decl.lent, NULL, NULL, + FALSE); + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_subrargs_.dim_list.dims != NULL) + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + return (ffelexHandler) ffestb_decl_ents_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + { + ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind, + ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims, + ffestb_local_.decl.len, ffestb_local_.decl.lent, NULL, NULL, + FALSE); + ffestc_decl_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_subrargs_.dim_list.dims != NULL) + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeEQUALS: + if (!ffestb_local_.decl.coloncolon) + ffesta_ffebad_1t (FFEBAD_INVALID_TYPEDECL_INIT, t); + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + ffestb_local_.decl.parameter ? FFEEXPR_contextPARAMETER + : FFEEXPR_contextINITVAL, (ffeexprCallback) ffestb_decl_ents_8_); + + case FFELEX_typeSLASH: + if (!ffesta_is_inhibited ()) + { + ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind, + ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims, + ffestb_local_.decl.len, ffestb_local_.decl.lent, NULL, NULL, + TRUE); + ffestc_decl_itemstartvals (); + } + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_subrargs_.dim_list.dims != NULL) + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + return (ffelexHandler) ffeexpr_rhs + (ffesta_output_pool, FFEEXPR_contextDATA, + (ffeexprCallback) ffestb_decl_ents_9_); + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_decl_finish (); + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_subrargs_.dim_list.dims != NULL) + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_ents_8_ -- "type" [type parameters] [attributes "::"] NAME + [ASTERISK NUMBER] [OPEN_PAREN dimlist CLOSE_PAREN] + [ASTERISK charlength] EQUALS expr + + (ffestb_decl_ents_8_) // to expression handler + + Handle COMMA or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_decl_ents_8_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind, + ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims, + ffestb_local_.decl.len, ffestb_local_.decl.lent, expr, ft, + FALSE); + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_subrargs_.dim_list.dims != NULL) + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + return (ffelexHandler) ffestb_decl_ents_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + { + ffestc_decl_item (ffesta_tokens[1], ffestb_local_.decl.kind, + ffestb_local_.decl.kindt, ffestb_subrargs_.dim_list.dims, + ffestb_local_.decl.len, ffestb_local_.decl.lent, expr, ft, + FALSE); + ffestc_decl_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_subrargs_.dim_list.dims != NULL) + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_decl_finish (); + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_subrargs_.dim_list.dims != NULL) + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_ents_9_ -- "type" ... SLASH expr + + (ffestb_decl_ents_9_) // to expression handler + + Handle ASTERISK, COMMA, or SLASH. */ + +static ffelexHandler +ffestb_decl_ents_9_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + ffestc_decl_itemvalue (NULL, NULL, expr, ft); + return (ffelexHandler) ffeexpr_rhs + (ffesta_output_pool, FFEEXPR_contextDATA, + (ffeexprCallback) ffestb_decl_ents_9_); + + case FFELEX_typeASTERISK: + if (expr == NULL) + break; + ffestb_local_.decl.expr = expr; + ffesta_tokens[1] = ffelex_token_use (ft); + return (ffelexHandler) ffeexpr_rhs + (ffesta_output_pool, FFEEXPR_contextDATA, + (ffeexprCallback) ffestb_decl_ents_10_); + + case FFELEX_typeSLASH: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + { + ffestc_decl_itemvalue (NULL, NULL, expr, ft); + ffestc_decl_itemendvals (t); + } + return (ffelexHandler) ffestb_decl_ents_11_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + break; + } + + if (!ffesta_is_inhibited ()) + { + ffestc_decl_itemendvals (t); + ffestc_decl_finish (); + } + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_ents_10_ -- "type" ... SLASH expr ASTERISK expr + + (ffestb_decl_ents_10_) // to expression handler + + Handle COMMA or SLASH. */ + +static ffelexHandler +ffestb_decl_ents_10_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + ffestc_decl_itemvalue (ffestb_local_.decl.expr, ffesta_tokens[1], + expr, ft); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffeexpr_rhs + (ffesta_output_pool, FFEEXPR_contextDATA, + (ffeexprCallback) ffestb_decl_ents_9_); + + case FFELEX_typeSLASH: + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + { + ffestc_decl_itemvalue (ffestb_local_.decl.expr, ffesta_tokens[1], + expr, ft); + ffestc_decl_itemendvals (t); + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_decl_ents_11_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + break; + } + + if (!ffesta_is_inhibited ()) + { + ffestc_decl_itemendvals (t); + ffestc_decl_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_ents_11_ -- "type" [type parameters] [attributes "::"] NAME + [ASTERISK NUMBER] [OPEN_PAREN dimlist CLOSE_PAREN] + [ASTERISK charlength] SLASH initvals SLASH + + return ffestb_decl_ents_11_; // to lexer + + Handle COMMA or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_decl_ents_11_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_decl_ents_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + ffestc_decl_finish (); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_decl_finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_entsp_ -- "type" [type parameters] + + return ffestb_decl_entsp_; // to lexer + + Handle NAME or NAMES beginning either an entity (object) declaration or + a function definition.. */ + +static ffelexHandler +ffestb_decl_entsp_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_confirmed (); + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_decl_entsp_1_; + + case FFELEX_typeNAMES: + ffesta_confirmed (); + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_decl_entsp_2_; + + default: + break; + } + + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "type-declaration", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_entsp_1_ -- "type" [type parameters] NAME + + return ffestb_decl_entsp_1_; // to lexer + + If we get another NAME token here, then the previous one must be + "RECURSIVE" or "FUNCTION" and we handle it accordingly. Otherwise, + we send the previous and current token through to _ents_. */ + +static ffelexHandler +ffestb_decl_entsp_1_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + switch (ffestr_first (ffesta_tokens[1])) + { +#if FFESTR_F90 + case FFESTR_firstRECURSIVE: + if (ffestr_first (t) != FFESTR_firstFUNCTION) + { + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + break; + } + ffestb_local_.decl.recursive = ffesta_tokens[1]; + return (ffelexHandler) ffestb_decl_funcname_; +#endif + + case FFESTR_firstFUNCTION: + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_decl_funcname_ (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", ffesta_tokens[1]); + break; + } + break; + + default: + if ((ffelex_token_type (ffesta_tokens[1]) != FFELEX_typeNAMES) + && !ffesta_is_inhibited ()) + ffestc_decl_start (ffestb_local_.decl.type, ffesta_tokens[0], + ffestb_local_.decl.kind, ffestb_local_.decl.kindt, + ffestb_local_.decl.len, ffestb_local_.decl.lent); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + /* NAME/NAMES token already in ffesta_tokens[1]. */ + return (ffelexHandler) ffestb_decl_ents_1_ (t); + } + + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_entsp_2_ -- "type" [type parameters] NAMES + + return ffestb_decl_entsp_2_; // to lexer + + If we get an ASTERISK or OPEN_PAREN here, then if the previous NAMES + begins with "FUNCTION" or "RECURSIVEFUNCTION" and is followed by a + first-name-char, we have a possible syntactically ambiguous situation. + Otherwise, we have a straightforward situation just as if we went + through _entsp_1_ instead of here. */ + +static ffelexHandler +ffestb_decl_entsp_2_ (ffelexToken t) +{ + ffelexToken nt; + bool asterisk_ok; + char *p; + ffeTokenLength i; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeASTERISK: + ffesta_confirmed (); + switch (ffestb_local_.decl.type) + { + case FFESTP_typeINTEGER: + case FFESTP_typeREAL: + case FFESTP_typeCOMPLEX: + case FFESTP_typeLOGICAL: + asterisk_ok = (ffestb_local_.decl.kindt == NULL); + break; + + case FFESTP_typeCHARACTER: + asterisk_ok = (ffestb_local_.decl.lent == NULL); + break; + + case FFESTP_typeBYTE: + case FFESTP_typeWORD: + default: + asterisk_ok = FALSE; + break; + } + switch (ffestr_first (ffesta_tokens[1])) + { +#if FFESTR_F90 + case FFESTR_firstRECURSIVEFNCTN: + if (!asterisk_ok) + break; /* For our own convenience, treat as non-FN + stmt. */ + p = ffelex_token_text (ffesta_tokens[1]) + + (i = FFESTR_firstlRECURSIVEFNCTN); + if (!ffesrc_is_name_init (*p)) + break; + ffestb_local_.decl.recursive + = ffelex_token_name_from_names (ffesta_tokens[1], 0, + FFESTR_firstlRECURSIVEFNCTN); + ffesta_tokens[2] = ffelex_token_name_from_names (ffesta_tokens[1], + FFESTR_firstlRECURSIVEFNCTN, 0); + return (ffelexHandler) ffestb_decl_entsp_3_; +#endif + + case FFESTR_firstFUNCTION: + if (!asterisk_ok) + break; /* For our own convenience, treat as non-FN + stmt. */ + p = ffelex_token_text (ffesta_tokens[1]) + + (i = FFESTR_firstlFUNCTION); + if (!ffesrc_is_name_init (*p)) + break; + ffestb_local_.decl.recursive = NULL; + ffesta_tokens[2] = ffelex_token_name_from_names (ffesta_tokens[1], + FFESTR_firstlFUNCTION, 0); + return (ffelexHandler) ffestb_decl_entsp_3_; + + default: + break; + } + break; + + case FFELEX_typeOPEN_PAREN: + ffestb_local_.decl.aster_after = FALSE; + switch (ffestr_first (ffesta_tokens[1])) + { +#if FFESTR_F90 + case FFESTR_firstRECURSIVEFNCTN: + p = ffelex_token_text (ffesta_tokens[1]) + + (i = FFESTR_firstlRECURSIVEFNCTN); + if (!ffesrc_is_name_init (*p)) + break; + ffestb_local_.decl.recursive + = ffelex_token_name_from_names (ffesta_tokens[1], 0, + FFESTR_firstlRECURSIVEFNCTN); + ffesta_tokens[2] = ffelex_token_name_from_names (ffesta_tokens[1], + FFESTR_firstlRECURSIVEFNCTN, 0); + return (ffelexHandler) ffestb_decl_entsp_5_ (t); +#endif + + case FFESTR_firstFUNCTION: + p = ffelex_token_text (ffesta_tokens[1]) + + (i = FFESTR_firstlFUNCTION); + if (!ffesrc_is_name_init (*p)) + break; + ffestb_local_.decl.recursive = NULL; + ffesta_tokens[2] = ffelex_token_name_from_names (ffesta_tokens[1], + FFESTR_firstlFUNCTION, 0); + return (ffelexHandler) ffestb_decl_entsp_5_ (t); + + default: + break; + } + if ((ffestb_local_.decl.kindt != NULL) + || (ffestb_local_.decl.lent != NULL)) + break; /* Have kind/len type param, definitely not + assignment stmt. */ + return (ffelexHandler) ffestb_decl_entsp_1_ (t); + + default: + break; + } + + nt = ffelex_token_name_from_names (ffesta_tokens[1], 0, 0); + ffelex_token_kill (ffesta_tokens[1]); + ffesta_tokens[1] = nt; /* Change NAMES to NAME. */ + return (ffelexHandler) ffestb_decl_entsp_1_ (t); +} + +/* ffestb_decl_entsp_3_ -- "type" [type parameters] [RECURSIVE] FUNCTION + NAME ASTERISK + + return ffestb_decl_entsp_3_; // to lexer + + Handle NUMBER or OPEN_PAREN. */ + +static ffelexHandler +ffestb_decl_entsp_3_ (ffelexToken t) +{ + ffestb_local_.decl.aster_after = TRUE; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + switch (ffestb_local_.decl.type) + { + case FFESTP_typeINTEGER: + case FFESTP_typeREAL: + case FFESTP_typeCOMPLEX: + case FFESTP_typeLOGICAL: + ffestb_local_.decl.kindt = ffelex_token_use (t); + break; + + case FFESTP_typeCHARACTER: + ffestb_local_.decl.lent = ffelex_token_use (t); + break; + + case FFESTP_typeBYTE: + case FFESTP_typeWORD: + default: + assert (FALSE); + } + return (ffelexHandler) ffestb_decl_entsp_5_; + + case FFELEX_typeOPEN_PAREN: + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextCHARACTERSIZE, + (ffeexprCallback) ffestb_decl_entsp_4_); + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_entsp_4_ -- "type" [type parameters] [RECURSIVE] FUNCTION + NAME ASTERISK OPEN_PAREN expr + + (ffestb_decl_entsp_4_) // to expression handler + + Allow only CLOSE_PAREN; and deal with character-length expression. */ + +static ffelexHandler +ffestb_decl_entsp_4_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + switch (ffestb_local_.decl.type) + { + case FFESTP_typeCHARACTER: + ffestb_local_.decl.len = expr; + ffestb_local_.decl.lent = ffelex_token_use (ft); + break; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + break; + } + return (ffelexHandler) ffestb_decl_entsp_5_; + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_entsp_5_ -- "type" [type parameters] [RECURSIVE] FUNCTION + NAME [type parameter] + + return ffestb_decl_entsp_5_; // to lexer + + Make sure the next token is an OPEN_PAREN. Get the arg list or dimension + list. If it can't be an arg list, or if the CLOSE_PAREN is followed by + something other than EOS/SEMICOLON or NAME, then treat as dimension list + and handle statement as an R426/R501. If it can't be a dimension list, or + if the CLOSE_PAREN is followed by NAME, treat as an arg list and handle + statement as an R1219. If it can be either an arg list or a dimension + list and if the CLOSE_PAREN is followed by EOS/SEMICOLON, ask FFESTC + whether to treat the statement as an R426/R501 or an R1219 and act + accordingly. */ + +static ffelexHandler +ffestb_decl_entsp_5_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + if (ffestb_local_.decl.aster_after && (ffestb_local_.decl.len != NULL)) + { /* "CHARACTER[RECURSIVE]FUNCTIONxyz*(len-expr) + (..." must be a function-stmt, since the + (len-expr) cannot precede (array-spec) in + an object declaration but can precede + (name-list) in a function stmt. */ + ffelex_token_kill (ffesta_tokens[1]); + ffesta_tokens[1] = ffesta_tokens[2]; + return (ffelexHandler) ffestb_decl_funcname_4_ (t); + } + ffestb_local_.decl.toklist = ffestt_tokenlist_create (); + ffestb_local_.decl.empty = TRUE; + ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t)); + return (ffelexHandler) ffestb_decl_entsp_6_; + + default: + break; + } + + assert (ffestb_local_.decl.aster_after); + ffesta_confirmed (); /* We've seen an ASTERISK, so even EQUALS + confirmed. */ + ffestb_subr_ambig_to_ents_ (); + ffestb_subrargs_.dim_list.dims = NULL; + return (ffelexHandler) ffestb_decl_ents_7_ (t); +} + +/* ffestb_decl_entsp_6_ -- "type" [type parameters] [RECURSIVE] FUNCTION + NAME [type parameter] OPEN_PAREN + + return ffestb_decl_entsp_6_; // to lexer + + If CLOSE_PAREN, we definitely have an R1219 function-stmt, since + the notation "name()" is invalid for a declaration. */ + +static ffelexHandler +ffestb_decl_entsp_6_ (ffelexToken t) +{ + ffelexHandler next; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + if (!ffestb_local_.decl.empty) + { /* Trailing comma, just a warning for + stmt func def, so allow ambiguity. */ + ffestt_tokenlist_append (ffestb_local_.decl.toklist, + ffelex_token_use (t)); + return (ffelexHandler) ffestb_decl_entsp_8_; + } + ffelex_token_kill (ffesta_tokens[1]); + ffesta_tokens[1] = ffesta_tokens[2]; + next = (ffelexHandler) ffestt_tokenlist_handle + (ffestb_local_.decl.toklist, (ffelexHandler) ffestb_decl_funcname_4_); + ffestt_tokenlist_kill (ffestb_local_.decl.toklist); + return (ffelexHandler) (*next) (t); + + case FFELEX_typeNAME: + ffestb_local_.decl.empty = FALSE; + ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t)); + return (ffelexHandler) ffestb_decl_entsp_7_; + + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + case FFELEX_typePERCENT: + case FFELEX_typePERIOD: + case FFELEX_typeOPEN_PAREN: + if ((ffestb_local_.decl.kindt != NULL) + || (ffestb_local_.decl.lent != NULL)) + break; /* type(params)name or type*val name, either + way confirmed. */ + return (ffelexHandler) ffestb_subr_ambig_nope_ (t); + + default: + break; + } + + ffesta_confirmed (); + ffestb_subr_ambig_to_ents_ (); + next = (ffelexHandler) ffestt_tokenlist_handle (ffestb_local_.decl.toklist, + (ffelexHandler) ffestb_decl_ents_3_); + ffestt_tokenlist_kill (ffestb_local_.decl.toklist); + return (ffelexHandler) (*next) (t); +} + +/* ffestb_decl_entsp_7_ -- "type" [type parameters] [RECURSIVE] FUNCTION + NAME [type parameter] OPEN_PAREN NAME + + return ffestb_decl_entsp_7_; // to lexer + + Expect COMMA or CLOSE_PAREN to remain ambiguous, else not an R1219 + function-stmt. */ + +static ffelexHandler +ffestb_decl_entsp_7_ (ffelexToken t) +{ + ffelexHandler next; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t)); + return (ffelexHandler) ffestb_decl_entsp_8_; + + case FFELEX_typeCOMMA: + ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t)); + return (ffelexHandler) ffestb_decl_entsp_6_; + + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + case FFELEX_typePERCENT: + case FFELEX_typePERIOD: + case FFELEX_typeOPEN_PAREN: + if ((ffestb_local_.decl.kindt != NULL) + || (ffestb_local_.decl.lent != NULL)) + break; /* type(params)name or type*val name, either + way confirmed. */ + return (ffelexHandler) ffestb_subr_ambig_nope_ (t); + + default: + break; + } + + ffesta_confirmed (); + ffestb_subr_ambig_to_ents_ (); + next = (ffelexHandler) ffestt_tokenlist_handle (ffestb_local_.decl.toklist, + (ffelexHandler) ffestb_decl_ents_3_); + ffestt_tokenlist_kill (ffestb_local_.decl.toklist); + return (ffelexHandler) (*next) (t); +} + +/* ffestb_decl_entsp_8_ -- "type" [type parameters] [RECURSIVE] FUNCTION + NAME [type parameter] OPEN_PAREN name-list + CLOSE_PAREN + + return ffestb_decl_entsp_8_; // to lexer + + If EOS/SEMICOLON, situation remains ambiguous, ask FFESTC to resolve + it. If NAME (must be "RESULT", but that is checked later on), + definitely an R1219 function-stmt. Anything else, handle as entity decl. */ + +static ffelexHandler +ffestb_decl_entsp_8_ (ffelexToken t) +{ + ffelexHandler next; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (ffestc_is_decl_not_R1219 ()) + break; + /* Fall through. */ + case FFELEX_typeNAME: + ffesta_confirmed (); + ffelex_token_kill (ffesta_tokens[1]); + ffesta_tokens[1] = ffesta_tokens[2]; + next = (ffelexHandler) ffestt_tokenlist_handle + (ffestb_local_.decl.toklist, (ffelexHandler) ffestb_decl_funcname_4_); + ffestt_tokenlist_kill (ffestb_local_.decl.toklist); + return (ffelexHandler) (*next) (t); + + case FFELEX_typeEQUALS: + case FFELEX_typePOINTS: + case FFELEX_typePERCENT: + case FFELEX_typePERIOD: + case FFELEX_typeOPEN_PAREN: + if ((ffestb_local_.decl.kindt != NULL) + || (ffestb_local_.decl.lent != NULL)) + break; /* type(params)name or type*val name, either + way confirmed. */ + return (ffelexHandler) ffestb_subr_ambig_nope_ (t); + + default: + break; + } + + ffesta_confirmed (); + ffestb_subr_ambig_to_ents_ (); + next = (ffelexHandler) ffestt_tokenlist_handle (ffestb_local_.decl.toklist, + (ffelexHandler) ffestb_decl_ents_3_); + ffestt_tokenlist_kill (ffestb_local_.decl.toklist); + return (ffelexHandler) (*next) (t); +} + +/* ffestb_decl_func_ -- ["type" [type parameters]] RECURSIVE + + return ffestb_decl_func_; // to lexer + + Handle "FUNCTION". */ + +#if FFESTR_F90 +static ffelexHandler +ffestb_decl_func_ (ffelexToken t) +{ + char *p; + ffeTokenLength i; + + ffelex_set_names (FALSE); + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + if (ffestr_first (t) != FFESTR_firstFUNCTION) + break; + return (ffelexHandler) ffestb_decl_funcname_; + + case FFELEX_typeNAMES: + ffesta_confirmed (); + if (ffestr_first (t) != FFESTR_firstFUNCTION) + break; + p = ffelex_token_text (t) + (i = FFESTR_firstlFUNCTION); + if (*p == '\0') + break; + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffesta_tokens[1] = ffelex_token_name_from_names (t, i, 0); + return (ffelexHandler) ffestb_decl_funcname_1_; + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_i: /* :::::::::::::::::::: */ + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t, i, NULL); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_decl_funcname_ -- "type" [type parameters] [RECURSIVE] FUNCTION + + return ffestb_decl_funcname_; // to lexer + + Handle NAME of a function. */ + +static ffelexHandler +ffestb_decl_funcname_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_decl_funcname_1_; + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_funcname_1_ -- "type" [type parameters] [RECURSIVE] FUNCTION + NAME + + return ffestb_decl_funcname_1_; // to lexer + + Handle ASTERISK or OPEN_PAREN. */ + +static ffelexHandler +ffestb_decl_funcname_1_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeASTERISK: + return (ffelexHandler) ffestb_decl_funcname_2_; + + case FFELEX_typeOPEN_PAREN: + return (ffelexHandler) ffestb_decl_funcname_4_ (t); + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_funcname_2_ -- "type" [type parameters] [RECURSIVE] FUNCTION + NAME ASTERISK + + return ffestb_decl_funcname_2_; // to lexer + + Handle NUMBER or OPEN_PAREN. */ + +static ffelexHandler +ffestb_decl_funcname_2_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNUMBER: + switch (ffestb_local_.decl.type) + { + case FFESTP_typeINTEGER: + case FFESTP_typeREAL: + case FFESTP_typeCOMPLEX: + case FFESTP_typeLOGICAL: + if (ffestb_local_.decl.kindt == NULL) + ffestb_local_.decl.kindt = ffelex_token_use (t); + else + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + break; + + case FFESTP_typeCHARACTER: + if (ffestb_local_.decl.lent == NULL) + ffestb_local_.decl.lent = ffelex_token_use (t); + else + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + break; + + case FFESTP_typeBYTE: + case FFESTP_typeWORD: + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + break; + } + return (ffelexHandler) ffestb_decl_funcname_4_; + + case FFELEX_typeOPEN_PAREN: + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextCHARACTERSIZE, + (ffeexprCallback) ffestb_decl_funcname_3_); + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_funcname_3_ -- "type" [type parameters] [RECURSIVE] FUNCTION + NAME ASTERISK OPEN_PAREN expr + + (ffestb_decl_funcname_3_) // to expression handler + + Allow only CLOSE_PAREN; and deal with character-length expression. */ + +static ffelexHandler +ffestb_decl_funcname_3_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + if (expr == NULL) + break; + switch (ffestb_local_.decl.type) + { + case FFESTP_typeCHARACTER: + if (ffestb_local_.decl.lent == NULL) + { + ffestb_local_.decl.len = expr; + ffestb_local_.decl.lent = ffelex_token_use (ft); + } + else + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + break; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + break; + } + return (ffelexHandler) ffestb_decl_funcname_4_; + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_funcname_4_ -- "type" [type parameters] [RECURSIVE] FUNCTION + NAME [type parameter] + + return ffestb_decl_funcname_4_; // to lexer + + Make sure the next token is an OPEN_PAREN. Get the arg list and + then implement. */ + +static ffelexHandler +ffestb_decl_funcname_4_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + ffestb_subrargs_.name_list.args = ffestt_tokenlist_create (); + ffestb_subrargs_.name_list.handler + = (ffelexHandler) ffestb_decl_funcname_5_; + ffestb_subrargs_.name_list.is_subr = FALSE; + ffestb_subrargs_.name_list.names = FALSE; + return (ffelexHandler) ffestb_subr_name_list_; + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffelex_token_kill (ffesta_tokens[1]); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_funcname_5_ -- "type" [type parameters] [RECURSIVE] FUNCTION + NAME [type parameter] OPEN_PAREN arg-list + CLOSE_PAREN + + return ffestb_decl_funcname_5_; // to lexer + + Must have EOS/SEMICOLON or "RESULT" here. */ + +static ffelexHandler +ffestb_decl_funcname_5_ (ffelexToken t) +{ + if (!ffestb_subrargs_.name_list.ok) + goto bad; /* :::::::::::::::::::: */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R1219 (ffesta_tokens[1], ffestb_subrargs_.name_list.args, + ffestb_subrargs_.name_list.close_paren, ffestb_local_.decl.type, + ffestb_local_.decl.kind, ffestb_local_.decl.kindt, + ffestb_local_.decl.len, ffestb_local_.decl.lent, + ffestb_local_.decl.recursive, NULL); + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffestb_subrargs_.name_list.close_paren); + ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeNAME: + if (ffestr_other (t) != FFESTR_otherRESULT) + break; + return (ffelexHandler) ffestb_decl_funcname_6_; + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffestb_subrargs_.name_list.close_paren); + ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_funcname_6_ -- "type" [type parameters] [RECURSIVE] FUNCTION + NAME [type parameter] OPEN_PAREN arglist + CLOSE_PAREN "RESULT" + + return ffestb_decl_funcname_6_; // to lexer + + Make sure the next token is an OPEN_PAREN. */ + +static ffelexHandler +ffestb_decl_funcname_6_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + return (ffelexHandler) ffestb_decl_funcname_7_; + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffestb_subrargs_.name_list.close_paren); + ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_funcname_7_ -- "type" [type parameters] [RECURSIVE] FUNCTION + NAME [type parameter] OPEN_PAREN arglist + CLOSE_PAREN "RESULT" OPEN_PAREN + + return ffestb_decl_funcname_7_; // to lexer + + Make sure the next token is a NAME. */ + +static ffelexHandler +ffestb_decl_funcname_7_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[2] = ffelex_token_use (t); + return (ffelexHandler) ffestb_decl_funcname_8_; + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffestb_subrargs_.name_list.close_paren); + ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_funcname_8_ -- "type" [type parameters] [RECURSIVE] FUNCTION + NAME [type parameter] OPEN_PAREN arglist + CLOSE_PAREN "RESULT" OPEN_PAREN NAME + + return ffestb_decl_funcname_8_; // to lexer + + Make sure the next token is a CLOSE_PAREN. */ + +static ffelexHandler +ffestb_decl_funcname_8_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCLOSE_PAREN: + return (ffelexHandler) ffestb_decl_funcname_9_; + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffelex_token_kill (ffestb_subrargs_.name_list.close_paren); + ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_funcname_9_ -- "type" [type parameters] [RECURSIVE] FUNCTION + NAME [type parameter] OPEN_PAREN arg-list + CLOSE_PAREN "RESULT" OPEN_PAREN NAME CLOSE_PAREN + + return ffestb_decl_funcname_9_; // to lexer + + Must have EOS/SEMICOLON here. */ + +static ffelexHandler +ffestb_decl_funcname_9_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + ffestc_R1219 (ffesta_tokens[1], ffestb_subrargs_.name_list.args, + ffestb_subrargs_.name_list.close_paren, ffestb_local_.decl.type, + ffestb_local_.decl.kind, ffestb_local_.decl.kindt, + ffestb_local_.decl.len, ffestb_local_.decl.lent, + ffestb_local_.decl.recursive, ffesta_tokens[2]); + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffelex_token_kill (ffestb_subrargs_.name_list.close_paren); + ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + if (ffestb_local_.decl.recursive != NULL) + ffelex_token_kill (ffestb_local_.decl.recursive); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffelex_token_kill (ffesta_tokens[1]); + ffelex_token_kill (ffesta_tokens[2]); + ffelex_token_kill (ffestb_subrargs_.name_list.close_paren); + ffestt_tokenlist_kill (ffestb_subrargs_.name_list.args); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "FUNCTION", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V003 -- Parse the STRUCTURE statement + + return ffestb_V003; // to lexer + + Make sure the statement has a valid form for the STRUCTURE statement. + If it does, implement the statement. */ + +#if FFESTR_VXT +ffelexHandler +ffestb_V003 (ffelexToken t) +{ + ffeTokenLength i; + char *p; + ffelexToken nt; + ffelexHandler next; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstSTRUCTURE) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_V003_start (NULL); + ffestb_local_.structure.started = TRUE; + return (ffelexHandler) ffestb_V0034_ (t); + + case FFELEX_typeSLASH: + ffesta_confirmed (); + return (ffelexHandler) ffestb_V0031_; + } + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstSTRUCTURE) + goto bad_0; /* :::::::::::::::::::: */ + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlSTRUCTURE); + switch (ffelex_token_type (t)) + { + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); + break; + + case FFELEX_typeSLASH: + ffesta_confirmed (); + if (*p != '\0') + goto bad_1; /* :::::::::::::::::::: */ + return (ffelexHandler) ffestb_V0031_; + + case FFELEX_typeOPEN_PAREN: + break; + } + + /* Here, we have at least one char after "STRUCTURE" and t is COMMA, + EOS/SEMICOLON, or OPEN_PAREN. */ + + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + nt = ffelex_token_name_from_names (ffesta_tokens[0], i, 0); + if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN) + ffestb_local_.structure.started = FALSE; + else + { + if (!ffesta_is_inhibited ()) + ffestc_V003_start (NULL); + ffestb_local_.structure.started = TRUE; + } + next = (ffelexHandler) ffestb_V0034_ (nt); + ffelex_token_kill (nt); + return (ffelexHandler) (*next) (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "STRUCTURE", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "STRUCTURE", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "STRUCTURE", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0031_ -- "STRUCTURE" SLASH + + return ffestb_V0031_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_V0031_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_V0032_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "STRUCTURE", t); + break; + } + + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0032_ -- "STRUCTURE" SLASH NAME + + return ffestb_V0032_; // to lexer + + Handle SLASH. */ + +static ffelexHandler +ffestb_V0032_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeSLASH: + if (!ffesta_is_inhibited ()) + ffestc_V003_start (ffesta_tokens[1]); + ffestb_local_.structure.started = TRUE; + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_V0033_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "STRUCTURE", t); + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0033_ -- "STRUCTURE" SLASH NAME SLASH + + return ffestb_V0033_; // to lexer + + Handle NAME or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_V0033_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + return (ffelexHandler) ffestb_V0034_ (t); + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + ffestc_V003_finish (); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "STRUCTURE", t); + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0034_ -- "STRUCTURE" [SLASH NAME SLASH] + + return ffestb_V0034_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_V0034_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_V0035_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "STRUCTURE", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_V003_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0035_ -- "STRUCTURE" ... NAME + + return ffestb_V0035_; // to lexer + + Handle OPEN_PAREN. */ + +static ffelexHandler +ffestb_V0035_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + ffestb_subrargs_.dim_list.dims = ffestt_dimlist_create (); + ffestb_subrargs_.dim_list.handler = (ffelexHandler) ffestb_V0036_; + ffestb_subrargs_.dim_list.pool = ffesta_output_pool; + ffestb_subrargs_.dim_list.ctx = FFEEXPR_contextDIMLISTCOMMON; +#ifdef FFECOM_dimensionsMAX + ffestb_subrargs_.dim_list.ndims = 0; +#endif + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextDIMLISTCOMMON, (ffeexprCallback) ffestb_subr_dimlist_); + + case FFELEX_typeCOMMA: + if (!ffesta_is_inhibited ()) + ffestc_V003_item (ffesta_tokens[1], NULL); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_V0034_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + { + ffestc_V003_item (ffesta_tokens[1], NULL); + ffestc_V003_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "STRUCTURE", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_V003_finish (); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0036_ -- "STRUCTURE" ... NAME OPEN_PAREN dimlist CLOSE_PAREN + + return ffestb_V0036_; // to lexer + + Handle COMMA or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_V0036_ (ffelexToken t) +{ + if (!ffestb_subrargs_.dim_list.ok) + goto bad; /* :::::::::::::::::::: */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + if (!ffestb_local_.structure.started) + { + ffestc_V003_start (NULL); + ffestb_local_.structure.started = TRUE; + } + ffestc_V003_item (ffesta_tokens[1], + ffestb_subrargs_.dim_list.dims); + } + ffelex_token_kill (ffesta_tokens[1]); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + return (ffelexHandler) ffestb_V0034_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + { + if (!ffestb_local_.structure.started) + ffestc_V003_start (NULL); + ffestc_V003_item (ffesta_tokens[1], + ffestb_subrargs_.dim_list.dims); + ffestc_V003_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "STRUCTURE", t); + if (ffestb_local_.structure.started && !ffesta_is_inhibited ()) + ffestc_V003_finish (); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V016 -- Parse the RECORD statement + + return ffestb_V016; // to lexer + + Make sure the statement has a valid form for the RECORD statement. If it + does, implement the statement. */ + +ffelexHandler +ffestb_V016 (ffelexToken t) +{ + char *p; + ffeTokenLength i; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstRECORD) + goto bad_0; /* :::::::::::::::::::: */ + break; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstRECORD) + goto bad_0; /* :::::::::::::::::::: */ + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlRECORD); + if (*p != '\0') + goto bad_i; /* :::::::::::::::::::: */ + break; + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeSLASH: + break; + } + + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_V016_start (); + return (ffelexHandler) ffestb_V0161_; + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RECORD", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RECORD", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "RECORD", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0161_ -- "RECORD" SLASH + + return ffestb_V0161_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_V0161_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + if (!ffesta_is_inhibited ()) + ffestc_V016_item_structure (t); + return (ffelexHandler) ffestb_V0162_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RECORD", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_V016_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0162_ -- "RECORD" SLASH NAME + + return ffestb_V0162_; // to lexer + + Handle SLASH. */ + +static ffelexHandler +ffestb_V0162_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeSLASH: + return (ffelexHandler) ffestb_V0163_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RECORD", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_V016_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0163_ -- "RECORD" SLASH NAME SLASH + + return ffestb_V0163_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_V0163_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_V0164_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RECORD", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_V016_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0164_ -- "RECORD" ... NAME + + return ffestb_V0164_; // to lexer + + Handle OPEN_PAREN. */ + +static ffelexHandler +ffestb_V0164_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + ffestb_subrargs_.dim_list.dims = ffestt_dimlist_create (); + ffestb_subrargs_.dim_list.handler = (ffelexHandler) ffestb_V0165_; + ffestb_subrargs_.dim_list.pool = ffesta_output_pool; + ffestb_subrargs_.dim_list.ctx = FFEEXPR_contextDIMLISTCOMMON; +#ifdef FFECOM_dimensionsMAX + ffestb_subrargs_.dim_list.ndims = 0; +#endif + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextDIMLISTCOMMON, (ffeexprCallback) ffestb_subr_dimlist_); + + case FFELEX_typeCOMMA: + if (!ffesta_is_inhibited ()) + ffestc_V016_item_object (ffesta_tokens[1], NULL); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_V0166_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + { + ffestc_V016_item_object (ffesta_tokens[1], NULL); + ffestc_V016_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RECORD", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_V016_finish (); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0165_ -- "RECORD" ... NAME OPEN_PAREN dimlist CLOSE_PAREN + + return ffestb_V0165_; // to lexer + + Handle COMMA or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_V0165_ (ffelexToken t) +{ + if (!ffestb_subrargs_.dim_list.ok) + goto bad; /* :::::::::::::::::::: */ + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (!ffesta_is_inhibited ()) + ffestc_V016_item_object (ffesta_tokens[1], + ffestb_subrargs_.dim_list.dims); + ffelex_token_kill (ffesta_tokens[1]); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + return (ffelexHandler) ffestb_V0166_; + + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffesta_is_inhibited ()) + { + ffestc_V016_item_object (ffesta_tokens[1], + ffestb_subrargs_.dim_list.dims); + ffestc_V016_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RECORD", t); + if (ffestb_local_.structure.started && !ffesta_is_inhibited ()) + ffestc_V016_finish (); + ffestt_dimlist_kill (ffestb_subrargs_.dim_list.dims); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0166_ -- "RECORD" SLASH NAME SLASH NAME [OPEN_PAREN dimlist + CLOSE_PAREN] COMMA + + return ffestb_V0166_; // to lexer + + Handle NAME or SLASH. */ + +static ffelexHandler +ffestb_V0166_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_V0164_; + + case FFELEX_typeSLASH: + return (ffelexHandler) ffestb_V0161_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "RECORD", t); + break; + } + + if (!ffesta_is_inhibited ()) + ffestc_V016_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_V027 -- Parse the VXT PARAMETER statement + + return ffestb_V027; // to lexer + + Make sure the statement has a valid form for the VXT PARAMETER statement. + If it does, implement the statement. */ + +ffelexHandler +ffestb_V027 (ffelexToken t) +{ + char *p; + ffeTokenLength i; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstPARAMETER) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + break; + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + ffesta_confirmed (); + ffestb_local_.vxtparam.started = TRUE; + if (!ffesta_is_inhibited ()) + ffestc_V027_start (); + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_V0271_; + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstPARAMETER) + goto bad_0; /* :::::::::::::::::::: */ + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlPARAMETER); + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + break; + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + if (!ffesrc_is_name_init (*p)) + goto bad_i; /* :::::::::::::::::::: */ + ffestb_local_.vxtparam.started = FALSE; + ffesta_tokens[1] = ffelex_token_name_from_names (ffesta_tokens[0], i, + 0); + return (ffelexHandler) ffestb_V0271_ (t); + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ + +bad_i: /* :::::::::::::::::::: */ + ffesta_ffebad_1sp (FFEBAD_INVALID_STMT_FORM, "PARAMETER", ffesta_tokens[0], i, t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0271_ -- "PARAMETER" NAME + + return ffestb_V0271_; // to lexer + + Handle EQUALS. */ + +static ffelexHandler +ffestb_V0271_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEQUALS: + return (ffelexHandler) ffeexpr_rhs (ffesta_output_pool, + FFEEXPR_contextPARAMETER, (ffeexprCallback) ffestb_V0272_); + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", t); + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.vxtparam.started && !ffesta_is_inhibited ()) + ffestc_V027_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0272_ -- "PARAMETER" NAME EQUALS expr + + (ffestb_V0272_) // to expression handler + + Handle COMMA or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_V0272_ (ffelexToken ft, ffebld expr, ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffestb_local_.vxtparam.started) + { + if (ffestc_is_let_not_V027 ()) + break; /* Not a valid VXTPARAMETER stmt. */ + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_V027_start (); + ffestb_local_.vxtparam.started = TRUE; + } + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + { + ffestc_V027_item (ffesta_tokens[1], expr, ft); + ffestc_V027_finish (); + } + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeCOMMA: + ffesta_confirmed (); + if (!ffestb_local_.vxtparam.started) + { + if (!ffesta_is_inhibited ()) + ffestc_V027_start (); + ffestb_local_.vxtparam.started = TRUE; + } + if (expr == NULL) + break; + if (!ffesta_is_inhibited ()) + ffestc_V027_item (ffesta_tokens[1], expr, ft); + ffelex_token_kill (ffesta_tokens[1]); + return (ffelexHandler) ffestb_V0273_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + if (ffestb_local_.vxtparam.started && !ffesta_is_inhibited ()) + ffestc_V027_finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_V0273_ -- "PARAMETER" NAME EQUALS expr COMMA + + return ffestb_V0273_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_V0273_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_V0271_; + + default: + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "PARAMETER", t); + break; + } + + if (ffestb_local_.vxtparam.started && !ffesta_is_inhibited ()) + ffestc_V027_finish (); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_R539 -- Parse the IMPLICIT FUNCTION statement + + return ffestb_decl_R539; // to lexer + + Make sure the statement has a valid form for the IMPLICIT + statement. If it does, implement the statement. */ + +ffelexHandler +ffestb_decl_R539 (ffelexToken t) +{ + ffeTokenLength i; + char *p; + ffelexToken nt; + ffestrSecond kw; + + ffestb_local_.decl.recursive = NULL; + + switch (ffelex_token_type (ffesta_tokens[0])) + { + case FFELEX_typeNAME: + if (ffesta_first_kw != FFESTR_firstIMPLICIT) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + ffesta_confirmed (); /* Error, but clearly intended. */ + goto bad_1; /* :::::::::::::::::::: */ + + default: + goto bad_1; /* :::::::::::::::::::: */ + + case FFELEX_typeNAME: + break; + } + ffesta_confirmed (); + ffestb_local_.decl.imp_started = FALSE; + switch (ffesta_second_kw) + { + case FFESTR_secondINTEGER: + ffestb_local_.decl.type = FFESTP_typeINTEGER; + return (ffelexHandler) ffestb_decl_R5391_; + + case FFESTR_secondBYTE: + ffestb_local_.decl.type = FFESTP_typeBYTE; + return (ffelexHandler) ffestb_decl_R5391_; + + case FFESTR_secondWORD: + ffestb_local_.decl.type = FFESTP_typeWORD; + return (ffelexHandler) ffestb_decl_R5391_; + + case FFESTR_secondREAL: + ffestb_local_.decl.type = FFESTP_typeREAL; + return (ffelexHandler) ffestb_decl_R5391_; + + case FFESTR_secondCOMPLEX: + ffestb_local_.decl.type = FFESTP_typeCOMPLEX; + return (ffelexHandler) ffestb_decl_R5391_; + + case FFESTR_secondLOGICAL: + ffestb_local_.decl.type = FFESTP_typeLOGICAL; + return (ffelexHandler) ffestb_decl_R5391_; + + case FFESTR_secondCHARACTER: + ffestb_local_.decl.type = FFESTP_typeCHARACTER; + return (ffelexHandler) ffestb_decl_R5391_; + + case FFESTR_secondDOUBLE: + return (ffelexHandler) ffestb_decl_R5392_; + + case FFESTR_secondDOUBLEPRECISION: + ffestb_local_.decl.type = FFESTP_typeDBLPRCSN; + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_R539letters_; + + case FFESTR_secondDOUBLECOMPLEX: + ffestb_local_.decl.type = FFESTP_typeDBLCMPLX; + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_R539letters_; + + case FFESTR_secondNONE: + return (ffelexHandler) ffestb_decl_R5394_; + +#if FFESTR_F90 + case FFESTR_secondTYPE: + ffestb_local_.decl.type = FFESTP_typeTYPE; + return (ffelexHandler) ffestb_decl_R5393_; +#endif + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + case FFELEX_typeNAMES: + if (ffesta_first_kw != FFESTR_firstIMPLICIT) + goto bad_0; /* :::::::::::::::::::: */ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeCOLONCOLON: + case FFELEX_typeASTERISK: + case FFELEX_typeSEMICOLON: + case FFELEX_typeEOS: + ffesta_confirmed (); + break; + + case FFELEX_typeOPEN_PAREN: + break; + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + p = ffelex_token_text (ffesta_tokens[0]) + (i = FFESTR_firstlIMPLICIT); + if (!ffesrc_is_name_init (*p)) + goto bad_0; /* :::::::::::::::::::: */ + ffestb_local_.decl.imp_started = FALSE; + nt = ffelex_token_name_from_names (ffesta_tokens[0], + FFESTR_firstlIMPLICIT, 0); + kw = ffestr_second (nt); + ffelex_token_kill (nt); + switch (kw) + { + case FFESTR_secondINTEGER: + ffestb_local_.decl.type = FFESTP_typeINTEGER; + return (ffelexHandler) ffestb_decl_R5391_ (t); + + case FFESTR_secondBYTE: + ffestb_local_.decl.type = FFESTP_typeBYTE; + return (ffelexHandler) ffestb_decl_R5391_ (t); + + case FFESTR_secondWORD: + ffestb_local_.decl.type = FFESTP_typeWORD; + return (ffelexHandler) ffestb_decl_R5391_ (t); + + case FFESTR_secondREAL: + ffestb_local_.decl.type = FFESTP_typeREAL; + return (ffelexHandler) ffestb_decl_R5391_ (t); + + case FFESTR_secondCOMPLEX: + ffestb_local_.decl.type = FFESTP_typeCOMPLEX; + return (ffelexHandler) ffestb_decl_R5391_ (t); + + case FFESTR_secondLOGICAL: + ffestb_local_.decl.type = FFESTP_typeLOGICAL; + return (ffelexHandler) ffestb_decl_R5391_ (t); + + case FFESTR_secondCHARACTER: + ffestb_local_.decl.type = FFESTP_typeCHARACTER; + return (ffelexHandler) ffestb_decl_R5391_ (t); + + case FFESTR_secondDOUBLEPRECISION: + ffestb_local_.decl.type = FFESTP_typeDBLPRCSN; + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_R539letters_ (t); + + case FFESTR_secondDOUBLECOMPLEX: + ffestb_local_.decl.type = FFESTP_typeDBLCMPLX; + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_R539letters_ (t); + + case FFESTR_secondNONE: + return (ffelexHandler) ffestb_decl_R5394_ (t); + +#if FFESTR_F90 + case FFESTR_secondTYPE: + ffestb_local_.decl.type = FFESTP_typeTYPE; + return (ffelexHandler) ffestb_decl_R5393_ (t); +#endif + + default: + goto bad_1; /* :::::::::::::::::::: */ + } + + default: + goto bad_0; /* :::::::::::::::::::: */ + } + +bad_0: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IMPLICIT", ffesta_tokens[0]); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); + +bad_1: /* :::::::::::::::::::: */ + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IMPLICIT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, + (ffelexHandler) ffesta_zero); /* Invalid second token. */ +} + +/* ffestb_decl_R5391_ -- "IMPLICIT" generic-type + + return ffestb_decl_R5391_; // to lexer + + Handle ASTERISK or OPEN_PAREN. */ + +static ffelexHandler +ffestb_decl_R5391_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeASTERISK: + ffesta_confirmed (); + ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_R539letters_; + ffestb_local_.decl.badname = "IMPLICIT"; + if (ffestb_local_.decl.type == FFESTP_typeCHARACTER) + return (ffelexHandler) ffestb_decl_starlen_; + return (ffelexHandler) ffestb_decl_starkind_; + + case FFELEX_typeOPEN_PAREN: + ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_R539letters_; + ffestb_local_.decl.badname = "IMPLICIT"; + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + if (ffestb_local_.decl.type == FFESTP_typeCHARACTER) + ffestb_local_.decl.imp_handler + = (ffelexHandler) ffestb_decl_typeparams_; + else + ffestb_local_.decl.imp_handler + = (ffelexHandler) ffestb_decl_kindparam_; + return (ffelexHandler) ffestb_decl_R539maybe_ (t); + + default: + break; + } + + if (ffestb_local_.decl.imp_started && !ffesta_is_inhibited ()) + ffestc_R539finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IMPLICIT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_R5392_ -- "IMPLICIT" "DOUBLE" + + return ffestb_decl_R5392_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_decl_R5392_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + switch (ffestr_second (t)) + { + case FFESTR_secondPRECISION: + ffestb_local_.decl.type = FFESTP_typeDBLPRCSN; + break; + + case FFESTR_secondCOMPLEX: + ffestb_local_.decl.type = FFESTP_typeDBLCMPLX; + break; + + default: + goto bad; /* :::::::::::::::::::: */ + } + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_R539letters_; + + default: + break; + } + +bad: /* :::::::::::::::::::: */ + if (ffestb_local_.decl.imp_started && !ffesta_is_inhibited ()) + ffestc_R539finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IMPLICIT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_R5393_ -- "IMPLICIT" "TYPE" + + return ffestb_decl_R5393_; // to lexer + + Handle OPEN_PAREN. */ + +#if FFESTR_F90 +static ffelexHandler +ffestb_decl_R5393_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + ffestb_local_.decl.handler = (ffelexHandler) ffestb_decl_R539letters_; + ffestb_local_.decl.badname = "IMPLICIT"; + return (ffelexHandler) ffestb_decl_typetype1_; + + default: + break; + } + + if (ffestb_local_.decl.imp_started && !ffesta_is_inhibited ()) + ffestc_R539finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IMPLICIT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +#endif +/* ffestb_decl_R5394_ -- "IMPLICIT" "NONE" + + return ffestb_decl_R5394_; // to lexer + + Handle EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_decl_R5394_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R539 (); /* IMPLICIT NONE. */ + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IMPLICIT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_R5395_ -- "IMPLICIT" implicit-spec-list COMMA + + return ffestb_decl_R5395_; // to lexer + + Handle NAME for next type-spec. */ + +static ffelexHandler +ffestb_decl_R5395_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + switch (ffestr_second (t)) + { + case FFESTR_secondINTEGER: + ffestb_local_.decl.type = FFESTP_typeINTEGER; + return (ffelexHandler) ffestb_decl_R5391_; + + case FFESTR_secondBYTE: + ffestb_local_.decl.type = FFESTP_typeBYTE; + return (ffelexHandler) ffestb_decl_R5391_; + + case FFESTR_secondWORD: + ffestb_local_.decl.type = FFESTP_typeWORD; + return (ffelexHandler) ffestb_decl_R5391_; + + case FFESTR_secondREAL: + ffestb_local_.decl.type = FFESTP_typeREAL; + return (ffelexHandler) ffestb_decl_R5391_; + + case FFESTR_secondCOMPLEX: + ffestb_local_.decl.type = FFESTP_typeCOMPLEX; + return (ffelexHandler) ffestb_decl_R5391_; + + case FFESTR_secondLOGICAL: + ffestb_local_.decl.type = FFESTP_typeLOGICAL; + return (ffelexHandler) ffestb_decl_R5391_; + + case FFESTR_secondCHARACTER: + ffestb_local_.decl.type = FFESTP_typeCHARACTER; + return (ffelexHandler) ffestb_decl_R5391_; + + case FFESTR_secondDOUBLE: + return (ffelexHandler) ffestb_decl_R5392_; + + case FFESTR_secondDOUBLEPRECISION: + ffestb_local_.decl.type = FFESTP_typeDBLPRCSN; + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_R539letters_; + + case FFESTR_secondDOUBLECOMPLEX: + ffestb_local_.decl.type = FFESTP_typeDBLCMPLX; + ffestb_local_.decl.kind = NULL; + ffestb_local_.decl.kindt = NULL; + ffestb_local_.decl.len = NULL; + ffestb_local_.decl.lent = NULL; + return (ffelexHandler) ffestb_decl_R539letters_; + +#if FFESTR_F90 + case FFESTR_secondTYPE: + ffestb_local_.decl.type = FFESTP_typeTYPE; + return (ffelexHandler) ffestb_decl_R5393_; +#endif + + default: + break; + } + break; + + default: + break; + } + + if (ffestb_local_.decl.imp_started && !ffesta_is_inhibited ()) + ffestc_R539finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IMPLICIT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_R539letters_ -- "IMPLICIT" type-spec + + return ffestb_decl_R539letters_; // to lexer + + Handle OPEN_PAREN. */ + +static ffelexHandler +ffestb_decl_R539letters_ (ffelexToken t) +{ + ffelex_set_names (FALSE); + + switch (ffelex_token_type (t)) + { + case FFELEX_typeOPEN_PAREN: + ffestb_local_.decl.imps = ffestt_implist_create (); + return (ffelexHandler) ffestb_decl_R539letters_1_; + + default: + break; + } + + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + if (ffestb_local_.decl.imp_started && !ffesta_is_inhibited ()) + ffestc_R539finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IMPLICIT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_R539letters_1_ -- "IMPLICIT" type-spec OPEN_PAREN + + return ffestb_decl_R539letters_1_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_decl_R539letters_1_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + if (ffelex_token_length (t) != 1) + break; + ffesta_tokens[1] = ffelex_token_use (t); + return (ffelexHandler) ffestb_decl_R539letters_2_; + + default: + break; + } + + ffestt_implist_kill (ffestb_local_.decl.imps); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + if (ffestb_local_.decl.imp_started && !ffesta_is_inhibited ()) + ffestc_R539finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IMPLICIT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_R539letters_2_ -- "IMPLICIT" type-spec OPEN_PAREN NAME + + return ffestb_decl_R539letters_2_; // to lexer + + Handle COMMA or MINUS. */ + +static ffelexHandler +ffestb_decl_R539letters_2_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffestt_implist_append (ffestb_local_.decl.imps, ffesta_tokens[1], NULL); + return (ffelexHandler) ffestb_decl_R539letters_1_; + + case FFELEX_typeCLOSE_PAREN: + ffestt_implist_append (ffestb_local_.decl.imps, ffesta_tokens[1], NULL); + return (ffelexHandler) ffestb_decl_R539letters_5_; + + case FFELEX_typeMINUS: + return (ffelexHandler) ffestb_decl_R539letters_3_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffestt_implist_kill (ffestb_local_.decl.imps); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + if (ffestb_local_.decl.imp_started && !ffesta_is_inhibited ()) + ffestc_R539finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IMPLICIT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_R539letters_3_ -- "IMPLICIT" type-spec OPEN_PAREN NAME MINUS + + return ffestb_decl_R539letters_3_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_decl_R539letters_3_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + if (ffelex_token_length (t) != 1) + break; + ffestt_implist_append (ffestb_local_.decl.imps, ffesta_tokens[1], + ffelex_token_use (t)); + return (ffelexHandler) ffestb_decl_R539letters_4_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffestt_implist_kill (ffestb_local_.decl.imps); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + if (ffestb_local_.decl.imp_started && !ffesta_is_inhibited ()) + ffestc_R539finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IMPLICIT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_R539letters_4_ -- "IMPLICIT" type-spec OPEN_PAREN NAME MINUS + NAME + + return ffestb_decl_R539letters_4_; // to lexer + + Handle COMMA or CLOSE_PAREN. */ + +static ffelexHandler +ffestb_decl_R539letters_4_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + return (ffelexHandler) ffestb_decl_R539letters_1_; + + case FFELEX_typeCLOSE_PAREN: + return (ffelexHandler) ffestb_decl_R539letters_5_; + + default: + break; + } + + ffestt_implist_kill (ffestb_local_.decl.imps); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + if (ffestb_local_.decl.imp_started && !ffesta_is_inhibited ()) + ffestc_R539finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IMPLICIT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_R539letters_5_ -- "IMPLICIT" type-spec OPEN_PAREN + letter-spec-list CLOSE_PAREN + + return ffestb_decl_R539letters_5_; // to lexer + + Handle COMMA or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_decl_R539letters_5_ (ffelexToken t) +{ + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + if (!ffestb_local_.decl.imp_started) + { + ffestb_local_.decl.imp_started = TRUE; + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R539start (); + } + if (!ffesta_is_inhibited ()) + ffestc_R539item (ffestb_local_.decl.type, ffestb_local_.decl.kind, + ffestb_local_.decl.kindt, ffestb_local_.decl.len, + ffestb_local_.decl.lent, ffestb_local_.decl.imps); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffestt_implist_kill (ffestb_local_.decl.imps); + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_decl_R5395_; + if (!ffesta_is_inhibited ()) + ffestc_R539finish (); + return (ffelexHandler) ffesta_zero (t); + + default: + break; + } + + ffestt_implist_kill (ffestb_local_.decl.imps); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + if (ffestb_local_.decl.imp_started && !ffesta_is_inhibited ()) + ffestc_R539finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IMPLICIT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} + +/* ffestb_decl_R539maybe_ -- "IMPLICIT" generic-type-spec + + return ffestb_decl_R539maybe_; // to lexer + + Handle OPEN_PAREN. */ + +static ffelexHandler +ffestb_decl_R539maybe_ (ffelexToken t) +{ + assert (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN); + ffestb_local_.decl.imps = ffestt_implist_create (); + ffestb_local_.decl.toklist = ffestt_tokenlist_create (); + ffestb_local_.decl.imp_seen_comma + = (ffestb_local_.decl.type != FFESTP_typeCHARACTER); + return (ffelexHandler) ffestb_decl_R539maybe_1_; +} + +/* ffestb_decl_R539maybe_1_ -- "IMPLICIT" generic-type-spec OPEN_PAREN + + return ffestb_decl_R539maybe_1_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_decl_R539maybe_1_ (ffelexToken t) +{ + ffelexHandler next; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + if (ffelex_token_length (t) != 1) + break; + ffesta_tokens[1] = ffelex_token_use (t); + ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t)); + return (ffelexHandler) ffestb_decl_R539maybe_2_; + + default: + break; + } + + ffestt_implist_kill (ffestb_local_.decl.imps); + next = (ffelexHandler) ffestt_tokenlist_handle (ffestb_local_.decl.toklist, + (ffelexHandler) ffestb_local_.decl.imp_handler); + ffestt_tokenlist_kill (ffestb_local_.decl.toklist); + return (ffelexHandler) (*next) (t); +} + +/* ffestb_decl_R539maybe_2_ -- "IMPLICIT" generic-type-spec OPEN_PAREN NAME + + return ffestb_decl_R539maybe_2_; // to lexer + + Handle COMMA or MINUS. */ + +static ffelexHandler +ffestb_decl_R539maybe_2_ (ffelexToken t) +{ + ffelexHandler next; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + ffestt_implist_append (ffestb_local_.decl.imps, ffesta_tokens[1], NULL); + if (ffestb_local_.decl.imp_seen_comma) + { + ffestt_tokenlist_kill (ffestb_local_.decl.toklist); + return (ffelexHandler) ffestb_decl_R539letters_1_; + } + ffestb_local_.decl.imp_seen_comma = TRUE; + ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t)); + return (ffelexHandler) ffestb_decl_R539maybe_1_; + + case FFELEX_typeCLOSE_PAREN: + ffestt_implist_append (ffestb_local_.decl.imps, ffesta_tokens[1], NULL); + ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t)); + return (ffelexHandler) ffestb_decl_R539maybe_5_; + + case FFELEX_typeMINUS: + ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t)); + return (ffelexHandler) ffestb_decl_R539maybe_3_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffestt_implist_kill (ffestb_local_.decl.imps); + next = (ffelexHandler) ffestt_tokenlist_handle (ffestb_local_.decl.toklist, + (ffelexHandler) ffestb_local_.decl.imp_handler); + ffestt_tokenlist_kill (ffestb_local_.decl.toklist); + return (ffelexHandler) (*next) (t); +} + +/* ffestb_decl_R539maybe_3_ -- "IMPLICIT" type-spec OPEN_PAREN NAME MINUS + + return ffestb_decl_R539maybe_3_; // to lexer + + Handle NAME. */ + +static ffelexHandler +ffestb_decl_R539maybe_3_ (ffelexToken t) +{ + ffelexHandler next; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeNAME: + if (ffelex_token_length (t) != 1) + break; + ffestt_implist_append (ffestb_local_.decl.imps, ffesta_tokens[1], + ffelex_token_use (t)); + ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t)); + return (ffelexHandler) ffestb_decl_R539maybe_4_; + + default: + break; + } + + ffelex_token_kill (ffesta_tokens[1]); + ffestt_implist_kill (ffestb_local_.decl.imps); + next = (ffelexHandler) ffestt_tokenlist_handle (ffestb_local_.decl.toklist, + (ffelexHandler) ffestb_local_.decl.imp_handler); + ffestt_tokenlist_kill (ffestb_local_.decl.toklist); + return (ffelexHandler) (*next) (t); +} + +/* ffestb_decl_R539maybe_4_ -- "IMPLICIT" type-spec OPEN_PAREN NAME MINUS + NAME + + return ffestb_decl_R539maybe_4_; // to lexer + + Handle COMMA or CLOSE_PAREN. */ + +static ffelexHandler +ffestb_decl_R539maybe_4_ (ffelexToken t) +{ + ffelexHandler next; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + if (ffestb_local_.decl.imp_seen_comma) + { + ffestt_tokenlist_kill (ffestb_local_.decl.toklist); + return (ffelexHandler) ffestb_decl_R539letters_1_; + } + ffestb_local_.decl.imp_seen_comma = TRUE; + ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t)); + return (ffelexHandler) ffestb_decl_R539maybe_1_; + + case FFELEX_typeCLOSE_PAREN: + ffestt_tokenlist_append (ffestb_local_.decl.toklist, ffelex_token_use (t)); + return (ffelexHandler) ffestb_decl_R539maybe_5_; + + default: + break; + } + + ffestt_implist_kill (ffestb_local_.decl.imps); + next = (ffelexHandler) ffestt_tokenlist_handle (ffestb_local_.decl.toklist, + (ffelexHandler) ffestb_local_.decl.imp_handler); + ffestt_tokenlist_kill (ffestb_local_.decl.toklist); + return (ffelexHandler) (*next) (t); +} + +/* ffestb_decl_R539maybe_5_ -- "IMPLICIT" type-spec OPEN_PAREN + letter-spec-list CLOSE_PAREN + + return ffestb_decl_R539maybe_5_; // to lexer + + Handle COMMA or EOS/SEMICOLON. */ + +static ffelexHandler +ffestb_decl_R539maybe_5_ (ffelexToken t) +{ + ffelexHandler next; + + switch (ffelex_token_type (t)) + { + case FFELEX_typeCOMMA: + case FFELEX_typeEOS: + case FFELEX_typeSEMICOLON: + ffestt_tokenlist_kill (ffestb_local_.decl.toklist); + if (!ffestb_local_.decl.imp_started) + { + ffestb_local_.decl.imp_started = TRUE; + ffesta_confirmed (); + if (!ffesta_is_inhibited ()) + ffestc_R539start (); + } + if (!ffesta_is_inhibited ()) + ffestc_R539item (ffestb_local_.decl.type, ffestb_local_.decl.kind, + ffestb_local_.decl.kindt, ffestb_local_.decl.len, + ffestb_local_.decl.lent, ffestb_local_.decl.imps); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + ffestt_implist_kill (ffestb_local_.decl.imps); + if (ffelex_token_type (t) == FFELEX_typeCOMMA) + return (ffelexHandler) ffestb_decl_R5395_; + if (!ffesta_is_inhibited ()) + ffestc_R539finish (); + return (ffelexHandler) ffesta_zero (t); + + case FFELEX_typeOPEN_PAREN: + ffesta_confirmed (); + ffestt_implist_kill (ffestb_local_.decl.imps); + next = (ffelexHandler) ffestt_tokenlist_handle (ffestb_local_.decl.toklist, + (ffelexHandler) ffestb_local_.decl.imp_handler); + ffestt_tokenlist_kill (ffestb_local_.decl.toklist); + return (ffelexHandler) (*next) (t); + + default: + break; + } + + ffestt_implist_kill (ffestb_local_.decl.imps); + ffestt_tokenlist_kill (ffestb_local_.decl.toklist); + if (ffestb_local_.decl.kindt != NULL) + ffelex_token_kill (ffestb_local_.decl.kindt); + if (ffestb_local_.decl.lent != NULL) + ffelex_token_kill (ffestb_local_.decl.lent); + if (ffestb_local_.decl.imp_started && !ffesta_is_inhibited ()) + ffestc_R539finish (); + ffesta_ffebad_1st (FFEBAD_INVALID_STMT_FORM, "IMPLICIT", t); + return (ffelexHandler) ffelex_swallow_tokens (t, (ffelexHandler) ffesta_zero); +} diff --git a/gcc/f/stb.h b/gcc/f/stb.h new file mode 100644 index 000000000000..a3385d9a5966 --- /dev/null +++ b/gcc/f/stb.h @@ -0,0 +1,253 @@ +/* stb.h -- Private #include File (module.h template V1.0) + Copyright (C) 1995, 1996 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Owning Modules: + stb.c + + Modifications: +*/ + +/* Allow multiple inclusion to work. */ + +#ifndef _H_f_stb +#define _H_f_stb + +/* Simple definitions and enumerations. */ + + +/* Typedefs. */ + + +/* Include files needed by this one. */ + +#include "bad.h" +#include "expr.h" +#include "lex.h" +#include "stp.h" +#include "str.h" + +/* Structure definitions. */ + +struct _ffestb_args_ + { + struct + { + char *badname; + ffeTokenLength len; /* Length of "ENTRY/FUNCTION/SUBROUTINE". */ + bool is_subr; /* TRUE if SUBROUTINE or if ENTRY within + SUBROUTINE. */ + } + dummy; + struct + { + char *badname; + ffeTokenLength len; /* Length of + "BACKSPACE/ENDFILE/REWIND/UNLOCK". */ + } + beru; + struct + { + ffeTokenLength len; /* Length of keyword including "END". */ + ffestrSecond second; /* Second keyword. */ + } + endxyz; + struct + { + ffestrSecond second; /* Second keyword. */ + } + elsexyz; + struct + { + ffeTokenLength len; /* Length of "STOP/PAUSE". */ + } + halt; +#if FFESTR_F90 + struct + { + char *badname; + ffeTokenLength len; /* Length of "ALLOCATE/DEALLOCATE". */ + ffeexprContext ctx; /* Either ALLOCATE or DEALLOCATE. */ + } + heap; +#endif + struct + { + char *badname; + ffeTokenLength len; /* Length of + "EXTERNAL/INTENT/INTRINSIC/OPTIONAL/PUBLIC/ + PRIVATE". */ + } + varlist; +#if FFESTR_VXT + struct + { + char *badname; + ffeTokenLength len; /* Length of "ENCODE/DECODE". */ + } + vxtcode; +#endif +#if FFESTR_F90 + struct + { + char *badname; + ffeTokenLength len; /* Length of "ALLOCATABLE/POINTER/TARGET". */ + } + dimlist; +#endif + struct + { + char *badname; + ffeTokenLength len; /* Length of "DIMENSION/VIRTUAL". */ + } + R524; + struct + { + ffeTokenLength len; /* Length of first keyword. */ + ffestpType type; /* Type of declaration. */ + } + decl; + }; + +/* Global objects accessed by users of this module. */ + +extern struct _ffestb_args_ ffestb_args; + +/* Declare functions with prototypes. */ + +ffelexHandler ffestb_beru (ffelexToken t); +ffelexHandler ffestb_block (ffelexToken t); +ffelexHandler ffestb_blockdata (ffelexToken t); +ffelexHandler ffestb_decl_chartype (ffelexToken t); +ffelexHandler ffestb_construct (ffelexToken t); +ffelexHandler ffestb_decl_dbltype (ffelexToken t); +ffelexHandler ffestb_decl_double (ffelexToken t); +ffelexHandler ffestb_dimlist (ffelexToken t); +ffelexHandler ffestb_do (ffelexToken t); +ffelexHandler ffestb_dowhile (ffelexToken t); +ffelexHandler ffestb_dummy (ffelexToken t); +ffelexHandler ffestb_else (ffelexToken t); +ffelexHandler ffestb_elsexyz (ffelexToken t); +ffelexHandler ffestb_end (ffelexToken t); +ffelexHandler ffestb_endxyz (ffelexToken t); +ffelexHandler ffestb_decl_gentype (ffelexToken t); +ffelexHandler ffestb_goto (ffelexToken t); +ffelexHandler ffestb_halt (ffelexToken t); +#if FFESTR_F90 +ffelexHandler ffestb_heap (ffelexToken t); +#endif +ffelexHandler ffestb_if (ffelexToken t); +ffelexHandler ffestb_let (ffelexToken t); +#if FFESTR_F90 +ffelexHandler ffestb_module (ffelexToken t); +#endif +#if FFESTR_F90 +ffelexHandler ffestb_decl_recursive (ffelexToken t); +#endif +#if FFESTR_F90 +ffelexHandler ffestb_type (ffelexToken t); +#endif +#if FFESTR_F90 +ffelexHandler ffestb_decl_typetype (ffelexToken t); +#endif +ffelexHandler ffestb_varlist (ffelexToken t); +#if FFESTR_VXT +ffelexHandler ffestb_vxtcode (ffelexToken t); +#endif +#if FFESTR_F90 +ffelexHandler ffestb_where (ffelexToken t); +#endif +#if HARD_F90 +ffelexHandler ffestb_R423B (ffelexToken t); +#endif +ffelexHandler ffestb_R522 (ffelexToken t); +ffelexHandler ffestb_R524 (ffelexToken t); +ffelexHandler ffestb_R528 (ffelexToken t); +ffelexHandler ffestb_R537 (ffelexToken t); +ffelexHandler ffestb_decl_R539 (ffelexToken t); +ffelexHandler ffestb_R542 (ffelexToken t); +ffelexHandler ffestb_R544 (ffelexToken t); +ffelexHandler ffestb_R547 (ffelexToken t); +#if FFESTR_F90 +ffelexHandler ffestb_R624 (ffelexToken t); +#endif +ffelexHandler ffestb_R809 (ffelexToken t); +ffelexHandler ffestb_R810 (ffelexToken t); +ffelexHandler ffestb_R834 (ffelexToken t); +ffelexHandler ffestb_R835 (ffelexToken t); +ffelexHandler ffestb_R838 (ffelexToken t); +ffelexHandler ffestb_R840 (ffelexToken t); +ffelexHandler ffestb_R841 (ffelexToken t); +ffelexHandler ffestb_R904 (ffelexToken t); +ffelexHandler ffestb_R907 (ffelexToken t); +ffelexHandler ffestb_R909 (ffelexToken t); +ffelexHandler ffestb_R910 (ffelexToken t); +ffelexHandler ffestb_R911 (ffelexToken t); +ffelexHandler ffestb_R923 (ffelexToken t); +ffelexHandler ffestb_R1001 (ffelexToken t); +ffelexHandler ffestb_R1102 (ffelexToken t); +#if FFESTR_F90 +ffelexHandler ffestb_R1107 (ffelexToken t); +#endif +#if FFESTR_F90 +ffelexHandler ffestb_R1202 (ffelexToken t); +#endif +ffelexHandler ffestb_R1212 (ffelexToken t); +ffelexHandler ffestb_R1227 (ffelexToken t); +#if FFESTR_F90 +ffelexHandler ffestb_R1228 (ffelexToken t); +#endif +ffelexHandler ffestb_R1229 (ffelexToken t); +ffelexHandler ffestb_S3P4 (ffelexToken t); +#if FFESTR_VXT +ffelexHandler ffestb_V003 (ffelexToken t); +ffelexHandler ffestb_V009 (ffelexToken t); +ffelexHandler ffestb_V012 (ffelexToken t); +#endif +ffelexHandler ffestb_V014 (ffelexToken t); +#if FFESTR_VXT +ffelexHandler ffestb_V016 (ffelexToken t); +ffelexHandler ffestb_V018 (ffelexToken t); +ffelexHandler ffestb_V019 (ffelexToken t); +#endif +ffelexHandler ffestb_V020 (ffelexToken t); +#if FFESTR_VXT +ffelexHandler ffestb_V021 (ffelexToken t); +ffelexHandler ffestb_V025 (ffelexToken t); +ffelexHandler ffestb_V026 (ffelexToken t); +#endif +ffelexHandler ffestb_V027 (ffelexToken t); + +/* Define macros. */ + +#define ffestb_init_0() +#define ffestb_init_1() +#define ffestb_init_2() +#define ffestb_init_3() +#define ffestb_init_4() +#define ffestb_terminate_0() +#define ffestb_terminate_1() +#define ffestb_terminate_2() +#define ffestb_terminate_3() +#define ffestb_terminate_4() + +/* End of #include file. */ + +#endif diff --git a/gcc/f/stc.c b/gcc/f/stc.c new file mode 100644 index 000000000000..ef91d7188ddb --- /dev/null +++ b/gcc/f/stc.c @@ -0,0 +1,13895 @@ +/* stc.c -- Implementation File (module.c template V1.0) + Copyright (C) 1995-1997 Free Software Foundation, Inc. + Contributed by James Craig Burley (burley@gnu.ai.mit.edu). + +This file is part of GNU Fortran. + +GNU Fortran is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Fortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Fortran; see the file COPYING. If not, write to +the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA +02111-1307, USA. + + Related Modules: + st.c + + Description: + Verifies the proper semantics for statements, checking expressions already + semantically analyzed individually, collectively, checking label defs and + refs, and so on. Uses ffebad to indicate errors in semantics. + + In many cases, both a token and a keyword (ffestrFirst, ffestrSecond, + or ffestrOther) is provided. ONLY USE THE TOKEN as a pointer to the + source-code location for an error message or similar; use the keyword + as the semantic matching for the token, since the token's text might + not match the keyword's code. For example, INTENT(IN OUT) A in free + source form passes to ffestc_R519_start the token "IN" but the keyword + FFESTR_otherINOUT, and the latter is correct. + + Generally, either a single ffestc function handles an entire statement, + in which case its name is ffestc_xyz_, or more than one function is + needed, in which case its names are ffestc_xyz_start_, + ffestc_xyz_item_ or ffestc_xyz_item_abc_, and ffestc_xyz_finish_. + The caller must call _start_ before calling any _item_ functions, and + must call _finish_ afterwards. If it is clearly a syntactic matter as + to restrictions on the number and variety of _item_ calls, then the caller + should report any errors and ffestc_ should presume it has been taken + care of and handle any semantic problems with grace and no error messages. + If the permitted number and variety of _item_ calls has some basis in + semantics, then the caller should not generate any messages and ffestc + should do all the checking. + + A few ffestc functions have names rather than grammar numbers, like + ffestc_elsewhere and ffestc_end. These are cases where the actual + statement depends on its context rather than just its form; ELSE WHERE + may be the obvious (WHERE...ELSE WHERE...END WHERE) or something a little + more subtle (WHERE: IF THEN...ELSE WHERE...END IF WHERE). The actual + ffestc functions do exist and do work, but may or may not be invoked + by ffestb depending on whether some form of resolution is possible. + For example, ffestc_R1103 end-program-stmt is reachable directly when + END PROGRAM [name] is specified, or via ffestc_end when END is specified + and the context is a main program. So ffestc_xyz_ should make a quick + determination of the context and pick the appropriate ffestc_Nxyz_ + function to invoke, without a lot of ceremony. + + Modifications: +*/ + +/* Include files. */ + +#include "proj.h" +#include "stc.h" +#include "bad.h" +#include "bld.h" +#include "data.h" +#include "expr.h" +#include "global.h" +#include "implic.h" +#include "lex.h" +#include "malloc.h" +#include "src.h" +#include "sta.h" +#include "std.h" +#include "stp.h" +#include "str.h" +#include "stt.h" +#include "stw.h" + +/* Externals defined here. */ + +ffeexprContext ffestc_iolist_context_ = FFEEXPR_contextIOLIST; +/* Valid only from READ/WRITE start to finish. */ + +/* Simple definitions and enumerations. */ + +typedef enum + { + FFESTC_orderOK_, /* Statement ok in this context, process. */ + FFESTC_orderBAD_, /* Statement not ok in this context, don't + process. */ + FFESTC_orderBADOK_, /* Don't process but push block if + applicable. */ + FFESTC + } ffestcOrder_; + +typedef enum + { + FFESTC_stateletSIMPLE_, /* Expecting simple/start. */ + FFESTC_stateletATTRIB_, /* Expecting attrib/item/itemstart. */ + FFESTC_stateletITEM_, /* Expecting item/itemstart/finish. */ + FFESTC_stateletITEMVALS_, /* Expecting itemvalue/itemendvals. */ + FFESTC_ + } ffestcStatelet_; + +/* Internal typedefs. */ + + +/* Private include files. */ + + +/* Internal structure definitions. */ + +union ffestc_local_u_ + { + struct + { + ffebld initlist; /* For list of one sym in INTEGER I/3/ case. */ + ffetargetCharacterSize stmt_size; + ffetargetCharacterSize size; + ffeinfoBasictype basic_type; + ffeinfoKindtype stmt_kind_type; + ffeinfoKindtype kind_type; + bool per_var_kind_ok; + char is_R426; /* 1=R426, 2=R501. */ + } + decl; + struct + { + ffebld objlist; /* For list of target objects. */ + ffebldListBottom list_bottom; /* For building lists. */ + } + data; + struct + { + ffebldListBottom list_bottom; /* For building lists. */ + int entry_num; + } + dummy; + struct + { + ffesymbol symbol; /* NML symbol. */ + } + namelist; + struct + { + ffelexToken t; /* First token in list. */ + ffeequiv eq; /* Current equivalence being built up. */ + ffebld list; /* List of expressions in equivalence. */ + ffebldListBottom bottom; + bool ok; /* TRUE while current list still being + processed. */ + bool save; /* TRUE if any var in list is SAVEd. */ + } + equiv; + struct + { + ffesymbol symbol; /* BCB/NCB symbol. */ + } + common; + struct + { + ffesymbol symbol; /* SFN symbol. */ + } + sfunc; +#if FFESTR_VXT + struct + { + char list_state; /* 0=>no field names allowed, 1=>error + reported already, 2=>field names req'd, + 3=>have a field name. */ + } + V003; +#endif + }; /* Merge with the one in ffestc later. */ + +/* Static objects accessed by functions in this module. */ + +static bool ffestc_ok_; /* _start_ fn's send this to _xyz_ fn's. */ +static bool ffestc_parent_ok_; /* Parent sym for baby sym fn's ok. */ +static char ffestc_namelist_; /* 0=>not namelist, 1=>namelist, 2=>error. */ +static union ffestc_local_u_ ffestc_local_; +static ffestcStatelet_ ffestc_statelet_ = FFESTC_stateletSIMPLE_; +static ffestwShriek ffestc_shriek_after1_ = NULL; +static unsigned long ffestc_blocknum_ = 0; /* Next block# to assign. */ +static int ffestc_entry_num_; +static int ffestc_sfdummy_argno_; +static int ffestc_saved_entry_num_; +static ffelab ffestc_label_; + +/* Static functions (internal). */ + +static void ffestc_R544_equiv_ (ffebld expr, ffelexToken t); +static void ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt, + ffebld len, ffelexToken lent); +static void ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet, + ffebld kind, ffelexToken kindt, + ffebld len, ffelexToken lent); +static void ffestc_establish_impletter_ (ffelexToken first, ffelexToken last); +static ffeinfoKindtype ffestc_kindtype_kind_ (ffeinfoBasictype bt, + ffetargetCharacterSize val); +static ffeinfoKindtype ffestc_kindtype_star_ (ffeinfoBasictype bt, + ffetargetCharacterSize val); +static void ffestc_labeldef_any_ (void); +static bool ffestc_labeldef_begin_ (void); +static void ffestc_labeldef_branch_begin_ (void); +static void ffestc_labeldef_branch_end_ (void); +static void ffestc_labeldef_endif_ (void); +static void ffestc_labeldef_format_ (void); +static void ffestc_labeldef_invalid_ (void); +static void ffestc_labeldef_notloop_ (void); +static void ffestc_labeldef_notloop_begin_ (void); +static void ffestc_labeldef_useless_ (void); +static bool ffestc_labelref_is_assignable_ (ffelexToken label_token, + ffelab *label); +static bool ffestc_labelref_is_branch_ (ffelexToken label_token, + ffelab *label); +static bool ffestc_labelref_is_format_ (ffelexToken label_token, + ffelab *label); +static bool ffestc_labelref_is_loopend_ (ffelexToken label_token, + ffelab *label); +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_access_ (void); +#endif +static ffestcOrder_ ffestc_order_actiondo_ (void); +static ffestcOrder_ ffestc_order_actionif_ (void); +static ffestcOrder_ ffestc_order_actionwhere_ (void); +static void ffestc_order_any_ (void); +static void ffestc_order_bad_ (void); +static ffestcOrder_ ffestc_order_blockdata_ (void); +static ffestcOrder_ ffestc_order_blockspec_ (void); +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_component_ (void); +#endif +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_contains_ (void); +#endif +static ffestcOrder_ ffestc_order_data_ (void); +static ffestcOrder_ ffestc_order_data77_ (void); +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_derivedtype_ (void); +#endif +static ffestcOrder_ ffestc_order_do_ (void); +static ffestcOrder_ ffestc_order_entry_ (void); +static ffestcOrder_ ffestc_order_exec_ (void); +static ffestcOrder_ ffestc_order_format_ (void); +static ffestcOrder_ ffestc_order_function_ (void); +static ffestcOrder_ ffestc_order_iface_ (void); +static ffestcOrder_ ffestc_order_ifthen_ (void); +static ffestcOrder_ ffestc_order_implicit_ (void); +static ffestcOrder_ ffestc_order_implicitnone_ (void); +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_interface_ (void); +#endif +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_map_ (void); +#endif +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_module_ (void); +#endif +static ffestcOrder_ ffestc_order_parameter_ (void); +static ffestcOrder_ ffestc_order_program_ (void); +static ffestcOrder_ ffestc_order_progspec_ (void); +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_record_ (void); +#endif +static ffestcOrder_ ffestc_order_selectcase_ (void); +static ffestcOrder_ ffestc_order_sfunc_ (void); +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_spec_ (void); +#endif +#if FFESTR_VXT +static ffestcOrder_ ffestc_order_structure_ (void); +#endif +static ffestcOrder_ ffestc_order_subroutine_ (void); +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_type_ (void); +#endif +static ffestcOrder_ ffestc_order_typedecl_ (void); +#if FFESTR_VXT +static ffestcOrder_ ffestc_order_union_ (void); +#endif +static ffestcOrder_ ffestc_order_unit_ (void); +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_use_ (void); +#endif +#if FFESTR_VXT +static ffestcOrder_ ffestc_order_vxtstructure_ (void); +#endif +#if FFESTR_F90 +static ffestcOrder_ ffestc_order_where_ (void); +#endif +static void ffestc_promote_dummy_ (ffelexToken t); +static void ffestc_promote_execdummy_ (ffelexToken t); +static void ffestc_promote_sfdummy_ (ffelexToken t); +static void ffestc_shriek_begin_program_ (void); +#if FFESTR_F90 +static void ffestc_shriek_begin_uses_ (void); +#endif +static void ffestc_shriek_blockdata_ (bool ok); +static void ffestc_shriek_do_ (bool ok); +static void ffestc_shriek_end_program_ (bool ok); +#if FFESTR_F90 +static void ffestc_shriek_end_uses_ (bool ok); +#endif +static void ffestc_shriek_function_ (bool ok); +static void ffestc_shriek_if_ (bool ok); +static void ffestc_shriek_ifthen_ (bool ok); +#if FFESTR_F90 +static void ffestc_shriek_interface_ (bool ok); +#endif +#if FFESTR_F90 +static void ffestc_shriek_map_ (bool ok); +#endif +#if FFESTR_F90 +static void ffestc_shriek_module_ (bool ok); +#endif +static void ffestc_shriek_select_ (bool ok); +#if FFESTR_VXT +static void ffestc_shriek_structure_ (bool ok); +#endif +static void ffestc_shriek_subroutine_ (bool ok); +#if FFESTR_F90 +static void ffestc_shriek_type_ (bool ok); +#endif +#if FFESTR_VXT +static void ffestc_shriek_union_ (bool ok); +#endif +#if FFESTR_F90 +static void ffestc_shriek_where_ (bool ok); +#endif +#if FFESTR_F90 +static void ffestc_shriek_wherethen_ (bool ok); +#endif +static int ffestc_subr_binsrch_ (char **list, int size, ffestpFile *spec, + char *whine); +static ffestvFormat ffestc_subr_format_ (ffestpFile *spec); +static bool ffestc_subr_is_branch_ (ffestpFile *spec); +static bool ffestc_subr_is_format_ (ffestpFile *spec); +static bool ffestc_subr_is_present_ (char *name, ffestpFile *spec); +static int ffestc_subr_speccmp_ (char *string, ffestpFile *spec, + char **target, int *length); +static ffestvUnit ffestc_subr_unit_ (ffestpFile *spec); +static void ffestc_try_shriek_do_ (void); + +/* Internal macros. */ + +#define ffestc_check_simple_() \ + assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_) +#define ffestc_check_start_() \ + assert(ffestc_statelet_ == FFESTC_stateletSIMPLE_); \ + ffestc_statelet_ = FFESTC_stateletATTRIB_ +#define ffestc_check_attrib_() \ + assert(ffestc_statelet_ == FFESTC_stateletATTRIB_) +#define ffestc_check_item_() \ + assert(ffestc_statelet_ == FFESTC_stateletATTRIB_ \ + || ffestc_statelet_ == FFESTC_stateletITEM_); \ + ffestc_statelet_ = FFESTC_stateletITEM_ +#define ffestc_check_item_startvals_() \ + assert(ffestc_statelet_ == FFESTC_stateletATTRIB_ \ + || ffestc_statelet_ == FFESTC_stateletITEM_); \ + ffestc_statelet_ = FFESTC_stateletITEMVALS_ +#define ffestc_check_item_value_() \ + assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_) +#define ffestc_check_item_endvals_() \ + assert(ffestc_statelet_ == FFESTC_stateletITEMVALS_); \ + ffestc_statelet_ = FFESTC_stateletITEM_ +#define ffestc_check_finish_() \ + assert(ffestc_statelet_ == FFESTC_stateletATTRIB_ \ + || ffestc_statelet_ == FFESTC_stateletITEM_); \ + ffestc_statelet_ = FFESTC_stateletSIMPLE_ +#define ffestc_order_action_() ffestc_order_exec_() +#if FFESTR_F90 +#define ffestc_order_interfacespec_() ffestc_order_derivedtype_() +#endif +#define ffestc_shriek_if_lost_ ffestc_shriek_if_ +#if FFESTR_F90 +#define ffestc_shriek_where_lost_ ffestc_shriek_where_ +#endif + +/* ffestc_establish_declinfo_ -- Determine specific type/params info for entity + + ffestc_establish_declinfo_(kind,kind_token,len,len_token); + + Must be called after _declstmt_ called to establish base type. */ + +static void +ffestc_establish_declinfo_ (ffebld kind, ffelexToken kindt, ffebld len, + ffelexToken lent) +{ + ffeinfoBasictype bt = ffestc_local_.decl.basic_type; + ffeinfoKindtype kt; + ffetargetCharacterSize val; + + if (kindt == NULL) + kt = ffestc_local_.decl.stmt_kind_type; + else if (!ffestc_local_.decl.per_var_kind_ok) + { + ffebad_start (FFEBAD_KINDTYPE); + ffebad_here (0, ffelex_token_where_line (kindt), + ffelex_token_where_column (kindt)); + ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + kt = ffestc_local_.decl.stmt_kind_type; + } + else + { + if (kind == NULL) + { + assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER); + val = atol (ffelex_token_text (kindt)); + kt = ffestc_kindtype_star_ (bt, val); + } + else if (ffebld_op (kind) == FFEBLD_opANY) + kt = ffestc_local_.decl.stmt_kind_type; + else + { + assert (ffebld_op (kind) == FFEBLD_opCONTER); + assert (ffeinfo_basictype (ffebld_info (kind)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (kind)) + == FFEINFO_kindtypeINTEGERDEFAULT); + val = ffebld_constant_integerdefault (ffebld_conter (kind)); + kt = ffestc_kindtype_kind_ (bt, val); + } + + if (kt == FFEINFO_kindtypeNONE) + { /* Not valid kind type. */ + ffebad_start (FFEBAD_KINDTYPE); + ffebad_here (0, ffelex_token_where_line (kindt), + ffelex_token_where_column (kindt)); + ffebad_here (1, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + kt = ffestc_local_.decl.stmt_kind_type; + } + } + + ffestc_local_.decl.kind_type = kt; + + /* Now check length specification for CHARACTER data type. */ + + if (((len == NULL) && (lent == NULL)) + || (bt != FFEINFO_basictypeCHARACTER)) + val = ffestc_local_.decl.stmt_size; + else + { + if (len == NULL) + { + assert (ffelex_token_type (lent) == FFELEX_typeNUMBER); + val = atol (ffelex_token_text (lent)); + } + else if (ffebld_op (len) == FFEBLD_opSTAR) + val = FFETARGET_charactersizeNONE; + else if (ffebld_op (len) == FFEBLD_opANY) + val = FFETARGET_charactersizeNONE; + else + { + assert (ffebld_op (len) == FFEBLD_opCONTER); + assert (ffeinfo_basictype (ffebld_info (len)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (len)) + == FFEINFO_kindtypeINTEGERDEFAULT); + val = ffebld_constant_integerdefault (ffebld_conter (len)); + } + } + + if ((val == 0) && !(0 && ffe_is_90 ())) + { + val = 1; + ffebad_start (FFEBAD_ZERO_SIZE); + ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent)); + ffebad_finish (); + } + ffestc_local_.decl.size = val; +} + +/* ffestc_establish_declstmt_ -- Establish host-specific type/params info + + ffestc_establish_declstmt_(type,type_token,kind,kind_token,len, + len_token); */ + +static void +ffestc_establish_declstmt_ (ffestpType type, ffelexToken typet, ffebld kind, + ffelexToken kindt, ffebld len, ffelexToken lent) +{ + ffeinfoBasictype bt; + ffeinfoKindtype ktd; /* Default kindtype. */ + ffeinfoKindtype kt; + ffetargetCharacterSize val; + bool per_var_kind_ok = TRUE; + + /* Determine basictype and default kindtype. */ + + switch (type) + { + case FFESTP_typeINTEGER: + bt = FFEINFO_basictypeINTEGER; + ktd = FFEINFO_kindtypeINTEGERDEFAULT; + break; + + case FFESTP_typeBYTE: + bt = FFEINFO_basictypeINTEGER; + ktd = FFEINFO_kindtypeINTEGER2; + break; + + case FFESTP_typeWORD: + bt = FFEINFO_basictypeINTEGER; + ktd = FFEINFO_kindtypeINTEGER3; + break; + + case FFESTP_typeREAL: + bt = FFEINFO_basictypeREAL; + ktd = FFEINFO_kindtypeREALDEFAULT; + break; + + case FFESTP_typeCOMPLEX: + bt = FFEINFO_basictypeCOMPLEX; + ktd = FFEINFO_kindtypeREALDEFAULT; + break; + + case FFESTP_typeLOGICAL: + bt = FFEINFO_basictypeLOGICAL; + ktd = FFEINFO_kindtypeLOGICALDEFAULT; + break; + + case FFESTP_typeCHARACTER: + bt = FFEINFO_basictypeCHARACTER; + ktd = FFEINFO_kindtypeCHARACTERDEFAULT; + break; + + case FFESTP_typeDBLPRCSN: + bt = FFEINFO_basictypeREAL; + ktd = FFEINFO_kindtypeREALDOUBLE; + per_var_kind_ok = FALSE; + break; + + case FFESTP_typeDBLCMPLX: + bt = FFEINFO_basictypeCOMPLEX; +#if FFETARGET_okCOMPLEX2 + ktd = FFEINFO_kindtypeREALDOUBLE; +#else + ktd = FFEINFO_kindtypeREALDEFAULT; + ffebad_start (FFEBAD_BAD_DBLCMPLX); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); +#endif + per_var_kind_ok = FALSE; + break; + + default: + assert ("Unexpected type (F90 TYPE?)!" == NULL); + bt = FFEINFO_basictypeNONE; + ktd = FFEINFO_kindtypeNONE; + break; + } + + if (kindt == NULL) + kt = ktd; + else + { /* Not necessarily default kind type. */ + if (kind == NULL) + { /* Shouldn't happen for CHARACTER. */ + assert (ffelex_token_type (kindt) == FFELEX_typeNUMBER); + val = atol (ffelex_token_text (kindt)); + kt = ffestc_kindtype_star_ (bt, val); + } + else if (ffebld_op (kind) == FFEBLD_opANY) + kt = ktd; + else + { + assert (ffebld_op (kind) == FFEBLD_opCONTER); + assert (ffeinfo_basictype (ffebld_info (kind)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (kind)) + == FFEINFO_kindtypeINTEGERDEFAULT); + val = ffebld_constant_integerdefault (ffebld_conter (kind)); + kt = ffestc_kindtype_kind_ (bt, val); + } + + if (kt == FFEINFO_kindtypeNONE) + { /* Not valid kind type. */ + ffebad_start (FFEBAD_KINDTYPE); + ffebad_here (0, ffelex_token_where_line (kindt), + ffelex_token_where_column (kindt)); + ffebad_here (1, ffelex_token_where_line (typet), + ffelex_token_where_column (typet)); + ffebad_finish (); + kt = ktd; + } + } + + ffestc_local_.decl.basic_type = bt; + ffestc_local_.decl.stmt_kind_type = kt; + ffestc_local_.decl.per_var_kind_ok = per_var_kind_ok; + + /* Now check length specification for CHARACTER data type. */ + + if (((len == NULL) && (lent == NULL)) + || (type != FFESTP_typeCHARACTER)) + val = (type == FFESTP_typeCHARACTER) ? 1 : FFETARGET_charactersizeNONE; + else + { + if (len == NULL) + { + assert (ffelex_token_type (lent) == FFELEX_typeNUMBER); + val = atol (ffelex_token_text (lent)); + } + else if (ffebld_op (len) == FFEBLD_opSTAR) + val = FFETARGET_charactersizeNONE; + else if (ffebld_op (len) == FFEBLD_opANY) + val = FFETARGET_charactersizeNONE; + else + { + assert (ffebld_op (len) == FFEBLD_opCONTER); + assert (ffeinfo_basictype (ffebld_info (len)) + == FFEINFO_basictypeINTEGER); + assert (ffeinfo_kindtype (ffebld_info (len)) + == FFEINFO_kindtypeINTEGERDEFAULT); + val = ffebld_constant_integerdefault (ffebld_conter (len)); + } + } + + if ((val == 0) && !(0 && ffe_is_90 ())) + { + val = 1; + ffebad_start (FFEBAD_ZERO_SIZE); + ffebad_here (0, ffelex_token_where_line (lent), ffelex_token_where_column (lent)); + ffebad_finish (); + } + ffestc_local_.decl.stmt_size = val; +} + +/* ffestc_establish_impletter_ -- Establish type/params for IMPLICIT letter(s) + + ffestc_establish_impletter_(first_letter_token,last_letter_token); */ + +static void +ffestc_establish_impletter_ (ffelexToken first, ffelexToken last) +{ + bool ok = FALSE; /* Stays FALSE if first letter > last. */ + char c; + + if (last == NULL) + ok = ffeimplic_establish_initial (c = *(ffelex_token_text (first)), + ffestc_local_.decl.basic_type, + ffestc_local_.decl.kind_type, + ffestc_local_.decl.size); + else + { + for (c = *(ffelex_token_text (first)); + c <= *(ffelex_token_text (last)); + c++) + { + ok = ffeimplic_establish_initial (c, + ffestc_local_.decl.basic_type, + ffestc_local_.decl.kind_type, + ffestc_local_.decl.size); + if (!ok) + break; + } + } + + if (!ok) + { + char cs[2]; + + cs[0] = c; + cs[1] = '\0'; + + ffebad_start (FFEBAD_BAD_IMPLICIT); + ffebad_here (0, ffelex_token_where_line (first), ffelex_token_where_column (first)); + ffebad_string (cs); + ffebad_finish (); + } +} + +/* ffestc_init_3 -- Initialize ffestc for new program unit + + ffestc_init_3(); */ + +void +ffestc_init_3 () +{ + ffestv_save_state_ = FFESTV_savestateNONE; + ffestc_entry_num_ = 0; + ffestv_num_label_defines_ = 0; +} + +/* ffestc_init_4 -- Initialize ffestc for new scoping unit + + ffestc_init_4(); + + For SUBROUTINEs/FUNCTIONs within INTERFACE/END INTERFACE, derived-TYPE- + defs, and statement function defs. */ + +void +ffestc_init_4 () +{ + ffestc_saved_entry_num_ = ffestc_entry_num_; + ffestc_entry_num_ = 0; +} + +/* ffestc_kindtype_kind_ -- Determine kindtype from basictype and KIND= value + + ffeinfoKindtype kt; + ffeinfoBasictype bt; + ffetargetCharacterSize val; + kt = ffestc_kindtype_kind_(bt,val); + if (kt == FFEINFO_kindtypeNONE) + // unsupported/invalid KIND= value for type */ + +static ffeinfoKindtype +ffestc_kindtype_kind_ (ffeinfoBasictype bt, ffetargetCharacterSize val) +{ + ffetype type; + ffetype base_type; + ffeinfoKindtype kt; + + base_type = ffeinfo_type (bt, 1); /* ~~ */ + assert (base_type != NULL); + + type = ffetype_lookup_kind (base_type, (int) val); + if (type == NULL) + return FFEINFO_kindtypeNONE; + + for (kt = 1; kt < FFEINFO_kindtype; ++kt) + if (ffeinfo_type (bt, kt) == type) + return kt; + + return FFEINFO_kindtypeNONE; +} + +/* ffestc_kindtype_star_ -- Determine kindtype from basictype and * value + + ffeinfoKindtype kt; + ffeinfoBasictype bt; + ffetargetCharacterSize val; + kt = ffestc_kindtype_star_(bt,val); + if (kt == FFEINFO_kindtypeNONE) + // unsupported/invalid * value for type */ + +static ffeinfoKindtype +ffestc_kindtype_star_ (ffeinfoBasictype bt, ffetargetCharacterSize val) +{ + ffetype type; + ffetype base_type; + ffeinfoKindtype kt; + + base_type = ffeinfo_type (bt, 1); /* ~~ */ + assert (base_type != NULL); + + type = ffetype_lookup_star (base_type, (int) val); + if (type == NULL) + return FFEINFO_kindtypeNONE; + + for (kt = 1; kt < FFEINFO_kindtype; ++kt) + if (ffeinfo_type (bt, kt) == type) + return kt; + + return FFEINFO_kindtypeNONE; +} + +/* Define label as usable for anything without complaint. */ + +static void +ffestc_labeldef_any_ () +{ + if ((ffesta_label_token == NULL) + || !ffestc_labeldef_begin_ ()) + return; + + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffestc_labeldef_branch_end_ (); +} + +/* ffestc_labeldef_begin_ -- Define label as unknown, initially + + ffestc_labeldef_begin_(); */ + +static bool +ffestc_labeldef_begin_ () +{ + ffelabValue label_value; + ffelab label; + + label_value = (ffelabValue) atol (ffelex_token_text (ffesta_label_token)); + if ((label_value == 0) || (label_value > FFELAB_valueMAX)) + { + ffebad_start (FFEBAD_LABEL_NUMBER_INVALID); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_finish (); + } + + label = ffelab_find (label_value); + if (label == NULL) + { + label = ffestc_label_ = ffelab_new (label_value); + ffestv_num_label_defines_++; + ffelab_set_definition_line (label, + ffewhere_line_use (ffelex_token_where_line (ffesta_label_token))); + ffelab_set_definition_column (label, + ffewhere_column_use (ffelex_token_where_column (ffesta_label_token))); + + return TRUE; + } + + if (ffewhere_line_is_unknown (ffelab_definition_line (label))) + { + ffestv_num_label_defines_++; + ffestc_label_ = label; + ffelab_set_definition_line (label, + ffewhere_line_use (ffelex_token_where_line (ffesta_label_token))); + ffelab_set_definition_column (label, + ffewhere_column_use (ffelex_token_where_column (ffesta_label_token))); + + return TRUE; + } + + ffebad_start (FFEBAD_LABEL_ALREADY_DEFINED); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_definition_line (label), + ffelab_definition_column (label)); + ffebad_string (ffelex_token_text (ffesta_label_token)); + ffebad_finish (); + + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; + return FALSE; +} + +/* ffestc_labeldef_branch_begin_ -- Define label as a branch target one + + ffestc_labeldef_branch_begin_(); */ + +static void +ffestc_labeldef_branch_begin_ () +{ + if ((ffesta_label_token == NULL) + || (ffestc_shriek_after1_ != NULL) + || !ffestc_labeldef_begin_ ()) + return; + + switch (ffelab_type (ffestc_label_)) + { + case FFELAB_typeUNKNOWN: + case FFELAB_typeASSIGNABLE: + ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP); + ffelab_set_blocknum (ffestc_label_, + ffestw_blocknum (ffestw_stack_top ())); + ffestd_labeldef_branch (ffestc_label_); + break; + + case FFELAB_typeNOTLOOP: + if (ffelab_blocknum (ffestc_label_) + < ffestw_blocknum (ffestw_stack_top ())) + { + ffebad_start (FFEBAD_LABEL_BLOCK); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + } + ffelab_set_blocknum (ffestc_label_, + ffestw_blocknum (ffestw_stack_top ())); + ffestd_labeldef_branch (ffestc_label_); + break; + + case FFELAB_typeLOOPEND: + if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) + || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) + { /* Unterminated block. */ + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); + ffebad_here (0, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_here (2, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_finish (); + break; + } + ffestd_labeldef_branch (ffestc_label_); + /* Leave something around for _branch_end_() to handle. */ + return; + + case FFELAB_typeFORMAT: + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + break; + + default: + assert ("bad label" == NULL); + /* Fall through. */ + case FFELAB_typeANY: + break; + } + + ffestc_try_shriek_do_ (); + + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; +} + +/* Define possible end of labeled-DO-loop. Call only after calling + ffestc_labeldef_branch_begin_, or when other branch_* functions + recognize that a label might also be serving as a branch end (in + which case they must issue a diagnostic). */ + +static void +ffestc_labeldef_branch_end_ () +{ + if (ffesta_label_token == NULL) + return; + + assert (ffestc_label_ != NULL); + assert ((ffelab_type (ffestc_label_) == FFELAB_typeLOOPEND) + || (ffelab_type (ffestc_label_) == FFELAB_typeANY)); + + while ((ffestw_state (ffestw_stack_top ()) == FFESTV_stateDO) + && (ffestw_label (ffestw_stack_top ()) == ffestc_label_)) + ffestc_shriek_do_ (TRUE); + + ffestc_try_shriek_do_ (); + + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; +} + +/* ffestc_labeldef_endif_ -- Define label as an END IF one + + ffestc_labeldef_endif_(); */ + +static void +ffestc_labeldef_endif_ () +{ + if ((ffesta_label_token == NULL) + || (ffestc_shriek_after1_ != NULL) + || !ffestc_labeldef_begin_ ()) + return; + + switch (ffelab_type (ffestc_label_)) + { + case FFELAB_typeUNKNOWN: + case FFELAB_typeASSIGNABLE: + ffelab_set_type (ffestc_label_, FFELAB_typeENDIF); + ffelab_set_blocknum (ffestc_label_, + ffestw_blocknum (ffestw_previous (ffestw_stack_top ()))); + ffestd_labeldef_endif (ffestc_label_); + break; + + case FFELAB_typeNOTLOOP: + if (ffelab_blocknum (ffestc_label_) + < ffestw_blocknum (ffestw_previous (ffestw_stack_top ()))) + { + ffebad_start (FFEBAD_LABEL_BLOCK); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + } + ffelab_set_blocknum (ffestc_label_, + ffestw_blocknum (ffestw_previous (ffestw_stack_top ()))); + ffestd_labeldef_endif (ffestc_label_); + break; + + case FFELAB_typeLOOPEND: + if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) + || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) + { /* Unterminated block. */ + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); + ffebad_here (0, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_here (2, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_finish (); + break; + } + ffestd_labeldef_endif (ffestc_label_); + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_finish (); + ffestc_labeldef_branch_end_ (); + return; + + case FFELAB_typeFORMAT: + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + break; + + default: + assert ("bad label" == NULL); + /* Fall through. */ + case FFELAB_typeANY: + break; + } + + ffestc_try_shriek_do_ (); + + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; +} + +/* ffestc_labeldef_format_ -- Define label as a FORMAT one + + ffestc_labeldef_format_(); */ + +static void +ffestc_labeldef_format_ () +{ + if ((ffesta_label_token == NULL) + || (ffestc_shriek_after1_ != NULL)) + { + ffebad_start (FFEBAD_FORMAT_NO_LABEL_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]), + ffelex_token_where_column (ffesta_tokens[0])); + ffebad_finish (); + return; + } + + if (!ffestc_labeldef_begin_ ()) + return; + + switch (ffelab_type (ffestc_label_)) + { + case FFELAB_typeUNKNOWN: + case FFELAB_typeASSIGNABLE: + ffelab_set_type (ffestc_label_, FFELAB_typeFORMAT); + ffestd_labeldef_format (ffestc_label_); + break; + + case FFELAB_typeFORMAT: + ffestd_labeldef_format (ffestc_label_); + break; + + case FFELAB_typeLOOPEND: + if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) + || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) + { /* Unterminated block. */ + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); + ffebad_here (0, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_here (2, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_finish (); + break; + } + ffestd_labeldef_format (ffestc_label_); + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_finish (); + ffestc_labeldef_branch_end_ (); + return; + + case FFELAB_typeNOTLOOP: + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + break; + + default: + assert ("bad label" == NULL); + /* Fall through. */ + case FFELAB_typeANY: + break; + } + + ffestc_try_shriek_do_ (); + + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; +} + +/* ffestc_labeldef_invalid_ -- Label definition invalid, complain if present + + ffestc_labeldef_invalid_(); */ + +static void +ffestc_labeldef_invalid_ () +{ + if ((ffesta_label_token == NULL) + || (ffestc_shriek_after1_ != NULL) + || !ffestc_labeldef_begin_ ()) + return; + + ffebad_start (FFEBAD_INVALID_LABEL_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_finish (); + + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffestc_try_shriek_do_ (); + + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; +} + +/* Define label as a non-loop-ending one on a statement that can't + be in the "then" part of a logical IF, such as a block-IF statement. */ + +static void +ffestc_labeldef_notloop_ () +{ + if (ffesta_label_token == NULL) + return; + + assert (ffestc_shriek_after1_ == NULL); + + if (!ffestc_labeldef_begin_ ()) + return; + + switch (ffelab_type (ffestc_label_)) + { + case FFELAB_typeUNKNOWN: + case FFELAB_typeASSIGNABLE: + ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP); + ffelab_set_blocknum (ffestc_label_, + ffestw_blocknum (ffestw_stack_top ())); + ffestd_labeldef_notloop (ffestc_label_); + break; + + case FFELAB_typeNOTLOOP: + if (ffelab_blocknum (ffestc_label_) + < ffestw_blocknum (ffestw_stack_top ())) + { + ffebad_start (FFEBAD_LABEL_BLOCK); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + } + ffelab_set_blocknum (ffestc_label_, + ffestw_blocknum (ffestw_stack_top ())); + ffestd_labeldef_notloop (ffestc_label_); + break; + + case FFELAB_typeLOOPEND: + if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) + || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) + { /* Unterminated block. */ + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); + ffebad_here (0, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_here (2, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_finish (); + break; + } + ffestd_labeldef_notloop (ffestc_label_); + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_finish (); + ffestc_labeldef_branch_end_ (); + return; + + case FFELAB_typeFORMAT: + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + break; + + default: + assert ("bad label" == NULL); + /* Fall through. */ + case FFELAB_typeANY: + break; + } + + ffestc_try_shriek_do_ (); + + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; +} + +/* Define label as a non-loop-ending one. Use this when it is + possible that the pending label is inhibited because we're in + the midst of a logical-IF, and thus _branch_end_ is going to + be called after the current statement to resolve a potential + loop-ending label. */ + +static void +ffestc_labeldef_notloop_begin_ () +{ + if ((ffesta_label_token == NULL) + || (ffestc_shriek_after1_ != NULL) + || !ffestc_labeldef_begin_ ()) + return; + + switch (ffelab_type (ffestc_label_)) + { + case FFELAB_typeUNKNOWN: + case FFELAB_typeASSIGNABLE: + ffelab_set_type (ffestc_label_, FFELAB_typeNOTLOOP); + ffelab_set_blocknum (ffestc_label_, + ffestw_blocknum (ffestw_stack_top ())); + ffestd_labeldef_notloop (ffestc_label_); + break; + + case FFELAB_typeNOTLOOP: + if (ffelab_blocknum (ffestc_label_) + < ffestw_blocknum (ffestw_stack_top ())) + { + ffebad_start (FFEBAD_LABEL_BLOCK); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + } + ffelab_set_blocknum (ffestc_label_, + ffestw_blocknum (ffestw_stack_top ())); + ffestd_labeldef_notloop (ffestc_label_); + break; + + case FFELAB_typeLOOPEND: + if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) + || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) + { /* Unterminated block. */ + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); + ffebad_here (0, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_here (2, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_finish (); + break; + } + ffestd_labeldef_branch (ffestc_label_); + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_finish (); + return; + + case FFELAB_typeFORMAT: + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + break; + + default: + assert ("bad label" == NULL); + /* Fall through. */ + case FFELAB_typeANY: + break; + } + + ffestc_try_shriek_do_ (); + + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; +} + +/* ffestc_labeldef_useless_ -- Define label as a useless one + + ffestc_labeldef_useless_(); */ + +static void +ffestc_labeldef_useless_ () +{ + if ((ffesta_label_token == NULL) + || (ffestc_shriek_after1_ != NULL) + || !ffestc_labeldef_begin_ ()) + return; + + switch (ffelab_type (ffestc_label_)) + { + case FFELAB_typeUNKNOWN: + ffelab_set_type (ffestc_label_, FFELAB_typeUSELESS); + ffestd_labeldef_useless (ffestc_label_); + break; + + case FFELAB_typeLOOPEND: + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + if ((ffestw_state (ffestw_stack_top ()) != FFESTV_stateDO) + || (ffestw_label (ffestw_stack_top ()) != ffestc_label_)) + { /* Unterminated block. */ + ffebad_start (FFEBAD_LABEL_DO_BLOCK_END); + ffebad_here (0, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_here (1, ffestw_line (ffestw_stack_top ()), ffestw_col (ffestw_stack_top ())); + ffebad_here (2, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_finish (); + break; + } + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_doref_line (ffestc_label_), + ffelab_doref_column (ffestc_label_)); + ffebad_finish (); + ffestc_labeldef_branch_end_ (); + return; + + case FFELAB_typeASSIGNABLE: + case FFELAB_typeFORMAT: + case FFELAB_typeNOTLOOP: + ffelab_set_type (ffestc_label_, FFELAB_typeANY); + ffestd_labeldef_any (ffestc_label_); + + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelex_token_where_line (ffesta_label_token), + ffelex_token_where_column (ffesta_label_token)); + ffebad_here (1, ffelab_firstref_line (ffestc_label_), + ffelab_firstref_column (ffestc_label_)); + ffebad_finish (); + break; + + default: + assert ("bad label" == NULL); + /* Fall through. */ + case FFELAB_typeANY: + break; + } + + ffestc_try_shriek_do_ (); + + ffelex_token_kill (ffesta_label_token); + ffesta_label_token = NULL; +} + +/* ffestc_labelref_is_assignable_ -- Reference to label in ASSIGN stmt + + if (ffestc_labelref_is_assignable_(label_token,&label)) + // label ref is ok, label is filled in with ffelab object */ + +static bool +ffestc_labelref_is_assignable_ (ffelexToken label_token, ffelab *x_label) +{ + ffelab label; + ffelabValue label_value; + + label_value = (ffelabValue) atol (ffelex_token_text (label_token)); + if ((label_value == 0) || (label_value > FFELAB_valueMAX)) + { + ffebad_start (FFEBAD_LABEL_NUMBER_INVALID); + ffebad_here (0, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + return FALSE; + } + + label = ffelab_find (label_value); + if (label == NULL) + { + label = ffelab_new (label_value); + ffelab_set_firstref_line (label, + ffewhere_line_use (ffelex_token_where_line (label_token))); + ffelab_set_firstref_column (label, + ffewhere_column_use (ffelex_token_where_column (label_token))); + } + + switch (ffelab_type (label)) + { + case FFELAB_typeUNKNOWN: + ffelab_set_type (label, FFELAB_typeASSIGNABLE); + break; + + case FFELAB_typeASSIGNABLE: + case FFELAB_typeLOOPEND: + case FFELAB_typeFORMAT: + case FFELAB_typeNOTLOOP: + case FFELAB_typeENDIF: + break; + + case FFELAB_typeUSELESS: + ffelab_set_type (label, FFELAB_typeANY); + ffestd_labeldef_any (label); + + ffebad_start (FFEBAD_LABEL_USE_DEF); + ffebad_here (0, ffelab_firstref_line (label), ffelab_firstref_column (label)); + ffebad_here (1, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + + ffestc_try_shriek_do_ (); + + return FALSE; + + default: + assert ("bad label" == NULL); + /* Fall through. */ + case FFELAB_typeANY: + break; + } + + *x_label = label; + return TRUE; +} + +/* ffestc_labelref_is_branch_ -- Reference to label in branch stmt + + if (ffestc_labelref_is_branch_(label_token,&label)) + // label ref is ok, label is filled in with ffelab object */ + +static bool +ffestc_labelref_is_branch_ (ffelexToken label_token, ffelab *x_label) +{ + ffelab label; + ffelabValue label_value; + ffestw block; + unsigned long blocknum; + + label_value = (ffelabValue) atol (ffelex_token_text (label_token)); + if ((label_value == 0) || (label_value > FFELAB_valueMAX)) + { + ffebad_start (FFEBAD_LABEL_NUMBER_INVALID); + ffebad_here (0, ffelex_token_where_line (label_token), + ffelex_token_where_column (label_token)); + ffebad_finish (); + return FALSE; + } + + label = ffelab_find (label_value); + if (label == NULL) + { + label = ffelab_new (label_value); + ffelab_set_firstref_line (label, + ffewhere_line_use (ffelex_token_where_line (label_token))); + ffelab_set_firstref_column (label, + ffewhere_column_use (ffelex_token_where_column (label_token))); + } + + switch (ffelab_type (label)) + { + case FFELAB_typeUNKNOWN: + case FFELAB_typeASSIGNABLE: + ffelab_set_type (label, FFELAB_typeNOTLOOP); + ffelab_set_blocknum (label, ffestw_blocknum (ffestw_stack_top ())); + break; + + case FFELAB_typeLOOPEND: + if (ffelab_blocknum (label) != 0) + break; /* Already taken care of. */ + for (block = ffestw_top_do (ffestw_stack_top ()); + (block != NULL) && (ffestw_label (block) != label); + block = ffestw_top_do (ffestw_previous (block))) + ; /* Find most recent DO